From b0a70419a67ff354baf0fe79c2aace671b32d13d Mon Sep 17 00:00:00 2001 From: dmjio Date: Fri, 18 Sep 2026 18:06:40 -0500 Subject: [PATCH 01/34] feat: MicroHs (`mhs`) browser backend MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds a third browser backend alongside GHCJS and WASM: MicroHs compiled through emscripten, linked against the standalone `js/miso.js` runtime. Everything is behind `__MHS__` (defined by `mhs` itself) or `MHS`, so the GHC, GHCJS and WASM builds are untouched. Library (29 modules under `src/`) * Traversals. MicroHs's `Prelude`/`Control.Monad` export list-only `mapM`/`mapM_`/`forM`/`forM_`/`sequence`/`sequence_`; the `Foldable`/`Traversable` ones live in `Data.Foldable` and `Data.Traversable`. 26 modules hide the list-only names and import the general ones under `__MHS__`. * Generics. `mhs` has no `DefaultSignatures` and no `TypeError`, so the generic default methods and their helper classes are compiled out: `GToJSVal`/`GFromJSVal` (`Miso.DSL`), `GToJSON`/`GFromJSON` plus `genericToJSON`/`genericParseJSON` (`Miso.JSON`) and `GRouter` (`Miso.Router`). Instances are written by hand on this backend. * `Miso.Lens`. No associated type families, so `At` becomes a multi-parameter class with functional dependencies (`class At at k v | at -> k, at -> v`) and the `Map`/`IntMap`/`Set`/ `IntSet`/list instances follow. `queue.at` is respelled `queue . at`: `mhs` lexes `x.at` as record selection. * `Miso.Runtime`. No `StableName`, so `dirtyCheck` drops the pointer- equality fast path and compares structurally; `performMajorGC` becomes `performGC`; `ThreadStatus` comes from `Control.Concurrent` rather than `GHC.Conc`. * `Miso.JSON`. The `JSON.stringify`/`JSON.parse` foreign imports are now shared with WASM (`#if defined(WASM) || defined(MHS)`), and the `Map MisoString v` parser uses `traverse` instead of `mapM`. * `Miso.CSS.Color`, `Miso.Router`: `Data.TypeLits` in place of `GHC.TypeLits`. `Miso.Subscription.Window`: hide `Options(..)` so the field selectors go with the type. FFI shims (`ffi/mhs`, on the include path via `-i../ffi/mhs`) * `Miso.DSL.FFI` — the `mhs` FFI layer, mirroring `ffi/wasm`: `JSVal`, `JSString`, callbacks and the marshaling primitives, over MicroHs's `GHC.Wasm.Prim`. `MisoString` is `Text` here, i.e. `MISO_TEXT` is always on. * `GHC.StaticPtr` — types and accessors only; `mhs` has no `static` syntax, so `unsafeLookupStaticPtr` yields `Nothing`. * `GHC.OverloadedLabels` — `IsLabel` over `Data.TypeLits`' `Symbol`, usable through `fromLabel` with a type application. * `GHC.Natural`, `Data.Text.Lazy.Encoding` — the slices miso uses. Build and test * `make mhs` (in `sample-app/`) builds `Main` with `mhs -XCPP -DMHS -DMISO_TEXT -i../src -i../ffi/mhs -t$(MHS_TARGET)` into `public-mhs/`, alongside `js/miso.js` and `static-mhs/index.html`. `MHS_TARGET` selects a section of MicroHs's `targets.conf`: `browser` (WebAssembly) or `browser_js` (JavaScript only, `-sWASM=0`). `make serve-mhs` serves the result. * `scripts/playwright-mhs.sh` + `ts/playwright-mhs.ts` — headless Chromium smoke test: build, serve on :8080, click the counter's `+`/`-` and print SUCCESS/ERROR, same protocol as `ts/playwright.ts`. * `.gitignore`: the `public-mhs/` build output. --- .gitignore | 1 + ffi/mhs/Data/Text/Lazy/Encoding.hs | 23 ++ ffi/mhs/GHC/Natural.hs | 21 ++ ffi/mhs/GHC/OverloadedLabels.hs | 22 ++ ffi/mhs/GHC/StaticPtr.hs | 40 +++ ffi/mhs/Miso/DSL/FFI.hs | 411 +++++++++++++++++++++++++++++ sample-app/Makefile | 15 ++ sample-app/static-mhs/index.html | 12 + scripts/playwright-mhs.sh | 18 ++ src/Miso.hs | 5 + src/Miso/CSS/Color.hs | 5 + src/Miso/Canvas.hs | 3 + src/Miso/Cookie.hs | 6 + src/Miso/DSL.hs | 36 +++ src/Miso/Data/Array.hs | 13 + src/Miso/Data/Map.hs | 6 + src/Miso/Data/Set.hs | 6 + src/Miso/Effect.hs | 5 + src/Miso/Event.hs | 6 + src/Miso/Event/Types.hs | 6 + src/Miso/FFI/Internal.hs | 9 + src/Miso/FFI/QQ.hs | 9 + src/Miso/Html/Render.hs | 5 + src/Miso/JSON.hs | 37 ++- src/Miso/JSON/Lexer.hs | 9 + src/Miso/Lens.hs | 29 +- src/Miso/Lens/TH.hs | 6 + src/Miso/Media.hs | 14 + src/Miso/Native/FFI.hs | 10 + src/Miso/Native/MainThread.hs | 6 + src/Miso/Reload.hs | 9 + src/Miso/Router.hs | 26 ++ src/Miso/Runtime.hs | 35 ++- src/Miso/Subscription/Cookie.hs | 6 + src/Miso/Subscription/History.hs | 10 + src/Miso/Subscription/Window.hs | 12 +- src/Miso/Util/Lexer.hs | 9 + src/Miso/Util/Parser.hs | 9 + ts/playwright-mhs.ts | 31 +++ 39 files changed, 928 insertions(+), 13 deletions(-) create mode 100644 ffi/mhs/Data/Text/Lazy/Encoding.hs create mode 100644 ffi/mhs/GHC/Natural.hs create mode 100644 ffi/mhs/GHC/OverloadedLabels.hs create mode 100644 ffi/mhs/GHC/StaticPtr.hs create mode 100644 ffi/mhs/Miso/DSL/FFI.hs create mode 100644 sample-app/static-mhs/index.html create mode 100755 scripts/playwright-mhs.sh create mode 100644 ts/playwright-mhs.ts diff --git a/.gitignore b/.gitignore index a522e3e9c..c194098ce 100644 --- a/.gitignore +++ b/.gitignore @@ -36,6 +36,7 @@ sample-app-native/build # haddocks haddocks/ /sample-app/public/ +/sample-app/public-mhs/ .gradle sample-app-native/android/app/src/main/assets/main.lynx.bundle diff --git a/ffi/mhs/Data/Text/Lazy/Encoding.hs b/ffi/mhs/Data/Text/Lazy/Encoding.hs new file mode 100644 index 000000000..4f5686784 --- /dev/null +++ b/ffi/mhs/Data/Text/Lazy/Encoding.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Text.Lazy.Encoding +-- Copyright : (C) 2016-2025 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +-- +-- Lazy text UTF-8 encoding for MicroHs, via the strict conversions. +----------------------------------------------------------------------------- +module Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) where +----------------------------------------------------------------------------- +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +----------------------------------------------------------------------------- +encodeUtf8 :: LT.Text -> BL.ByteString +encodeUtf8 = BL.fromStrict . T.encodeUtf8 . LT.toStrict +----------------------------------------------------------------------------- +decodeUtf8 :: BL.ByteString -> LT.Text +decodeUtf8 = LT.fromStrict . T.decodeUtf8 . BL.toStrict +----------------------------------------------------------------------------- diff --git a/ffi/mhs/GHC/Natural.hs b/ffi/mhs/GHC/Natural.hs new file mode 100644 index 000000000..2a4d26535 --- /dev/null +++ b/ffi/mhs/GHC/Natural.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Natural +-- Copyright : (C) 2016-2025 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +-- +-- The parts of GHC's "GHC.Natural" used by miso, for MicroHs. +----------------------------------------------------------------------------- +module GHC.Natural (Natural, naturalToInteger, naturalFromInteger) where +----------------------------------------------------------------------------- +import Numeric.Natural (Natural) +----------------------------------------------------------------------------- +naturalToInteger :: Natural -> Integer +naturalToInteger = toInteger +----------------------------------------------------------------------------- +naturalFromInteger :: Integer -> Natural +naturalFromInteger = fromInteger +----------------------------------------------------------------------------- diff --git a/ffi/mhs/GHC/OverloadedLabels.hs b/ffi/mhs/GHC/OverloadedLabels.hs new file mode 100644 index 000000000..2f807ff32 --- /dev/null +++ b/ffi/mhs/GHC/OverloadedLabels.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.OverloadedLabels +-- Copyright : (C) 2016-2025 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +-- +-- The 'IsLabel' class for MicroHs, which has no OverloadedLabels syntax. +-- Instances can still be defined and used via 'fromLabel' with a type application. +----------------------------------------------------------------------------- +module GHC.OverloadedLabels (IsLabel (..)) where +----------------------------------------------------------------------------- +import Data.TypeLits (Symbol) +----------------------------------------------------------------------------- +class IsLabel (x :: Symbol) a where + fromLabel :: a +----------------------------------------------------------------------------- diff --git a/ffi/mhs/GHC/StaticPtr.hs b/ffi/mhs/GHC/StaticPtr.hs new file mode 100644 index 000000000..a233caa0d --- /dev/null +++ b/ffi/mhs/GHC/StaticPtr.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StaticPtr +-- Copyright : (C) 2016-2025 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +-- +-- A minimal stand-in for GHC's "GHC.StaticPtr" when building with MicroHs, +-- which has no StaticPointers extension. Static pointers cannot be created +-- (there is no @static@ syntax), so only the types and accessors exist. +----------------------------------------------------------------------------- +module GHC.StaticPtr + ( StaticPtr + , StaticKey + , staticKey + , deRefStaticPtr + , unsafeLookupStaticPtr + , staticPtrKeys + ) where +----------------------------------------------------------------------------- +import GHC.Fingerprint (Fingerprint (..)) +----------------------------------------------------------------------------- +type StaticKey = Fingerprint +----------------------------------------------------------------------------- +data StaticPtr a = StaticPtr StaticKey a +----------------------------------------------------------------------------- +staticKey :: StaticPtr a -> StaticKey +staticKey (StaticPtr k _) = k +----------------------------------------------------------------------------- +deRefStaticPtr :: StaticPtr a -> a +deRefStaticPtr (StaticPtr _ a) = a +----------------------------------------------------------------------------- +unsafeLookupStaticPtr :: StaticKey -> IO (Maybe (StaticPtr a)) +unsafeLookupStaticPtr _ = pure Nothing +----------------------------------------------------------------------------- +staticPtrKeys :: IO [StaticKey] +staticPtrKeys = pure [] +----------------------------------------------------------------------------- diff --git a/ffi/mhs/Miso/DSL/FFI.hs b/ffi/mhs/Miso/DSL/FFI.hs new file mode 100644 index 000000000..b39844dcc --- /dev/null +++ b/ffi/mhs/Miso/DSL/FFI.hs @@ -0,0 +1,411 @@ +----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE InterruptibleFFI #-} +----------------------------------------------------------------------------- +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Miso.DSL.FFI +-- Copyright : (C) 2016-2025 David M. Johnson +-- License : BSD3-style (see the file LICENSE) +-- Maintainer : David M. Johnson +-- Stability : experimental +-- Portability : non-portable +-- +-- FFI layer for MicroHs (mhs) compiled with the emscripten target. +-- +-- This mirrors the WASM FFI layer (ffi/wasm), using the 'GHC.Wasm.Prim' +-- module of MicroHs, which provides 'JSVal', 'JSString', 'freeJSVal' and +-- the callback functions. 'MisoString' is 'Text' on this backend +-- (i.e., MISO_TEXT is always defined). +----------------------------------------------------------------------------- +module Miso.DSL.FFI + ( -- ** Types + JSVal + , JSString (..) + , now_ffi + -- ** Serialization FFI + -- *** ToJSVal + , toJSVal_Char + , toJSVal_Bool + , toJSVal_Double + , toJSVal_Float + , toJSVal_Int + , toJSVal_List + , toJSVal_JSString + , toJSVal_Text + -- *** FromJSVal + , fromJSVal_Text + , fromJSValUnchecked_Text + , fromJSVal_Char + , fromJSValUnchecked_Char + , fromJSVal_Bool + , fromJSValUnchecked_Bool + , fromJSVal_Double + , fromJSValUnchecked_Double + , fromJSVal_Float + , fromJSValUnchecked_Float + , fromJSVal_Int + , fromJSValUnchecked_Int + , fromJSVal_List + , fromJSValUnchecked_List + , fromJSVal_JSString + , fromJSVal_Maybe + , fromJSValUnchecked_Maybe + -- * Callback FFI + , await + , asyncCallback + , asyncCallback1 + , asyncCallback2 + , asyncCallback3 + , syncCallback + , syncCallback1 + , syncCallback2 + , syncCallback3 + , syncCallback' + , syncCallback1' + , syncCallback2' + , syncCallback3' + -- * DSL FFI + , invokeFunction + , setProp_ffi + , new_ffi + , getProp_ffi + , eval_ffi + , setPropIndex_ffi + , getPropIndex_ffi + , create_ffi + -- *** Misc. FFI + , global + , isUndefined_ffi + , isNull_ffi + , jsNull + , freeFunction_ffi + , freeJSVal_ffi + , requestAnimationFrame + , cancelAnimationFrame + , listProps_ffi + -- *** String FFI + , parseInt + , parseDouble + , parseWord + , parseFloat + , toString_Int + , toString_Double + , toString_Float + , toString_Word + , textFromJSString + , textToJSString + , JSException + ) where +----------------------------------------------------------------------------- +import Control.Monad +import Data.Char (isSpace) +import qualified Data.List as L +import Data.List (dropWhileEnd) +import Data.Text (Text) +import qualified Data.Text as T +import Numeric (readHex) +import Prelude hiding (length) +import Text.Read (readMaybe) +----------------------------------------------------------------------------- +import GHC.Wasm.Prim +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1 === $2" + eq :: JSVal -> JSVal -> Bool +----------------------------------------------------------------------------- +instance Eq JSVal where + (==) = eq +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + toJSVal_Bool :: Bool -> IO JSVal +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + toJSVal_Double :: Double -> IO JSVal +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + toJSVal_Int :: Int -> IO JSVal +----------------------------------------------------------------------------- +toJSVal_List :: [JSVal] -> IO JSVal +toJSVal_List js = do + arr <- newArray + forM_ js (pushArray arr) + pure arr +----------------------------------------------------------------------------- +foreign import javascript unsafe "[]" + newArray :: IO JSVal +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1.push($2)" + pushArray :: JSVal -> JSVal -> IO () +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + toJSVal_Char :: Char -> IO JSVal +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + toJSVal_Float :: Float -> IO JSVal +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + fromJSValUnchecked_Float :: JSVal -> IO Float +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + fromJSValUnchecked_Char :: JSVal -> IO Char +----------------------------------------------------------------------------- +fromJSVal_Char :: JSVal -> IO (Maybe Char) +fromJSVal_Char x = + if isNullOrUndefined x + then pure Nothing + else Just <$> fromJSValUnchecked_Char x +----------------------------------------------------------------------------- +toJSVal_JSString :: JSString -> IO JSVal +toJSVal_JSString (JSString jsval) = pure jsval +----------------------------------------------------------------------------- +fromJSVal_Text :: JSVal -> IO (Maybe Text) +fromJSVal_Text x = + if isNullOrUndefined x + then pure Nothing + else Just <$> fromJSValUnchecked_Text x +----------------------------------------------------------------------------- +fromJSValUnchecked_Text :: JSVal -> IO Text +fromJSValUnchecked_Text t = + pure $ textFromJSString (JSString t) +----------------------------------------------------------------------------- +toJSVal_Text :: Text -> IO JSVal +toJSVal_Text t = + case textToJSString t of + JSString jsval -> pure jsval +----------------------------------------------------------------------------- +fromJSVal_Float :: JSVal -> IO (Maybe Float) +fromJSVal_Float x = + if isNullOrUndefined x + then pure Nothing + else Just <$> fromJSValUnchecked_Float x +----------------------------------------------------------------------------- +fromJSVal_Bool :: JSVal -> IO (Maybe Bool) +fromJSVal_Bool x = + if isNullOrUndefined x + then pure Nothing + else Just <$> fromJSValUnchecked_Bool x +----------------------------------------------------------------------------- +fromJSVal_Int :: JSVal -> IO (Maybe Int) +fromJSVal_Int x = + if isNullOrUndefined x + then pure Nothing + else Just <$> fromJSValUnchecked_Int x +----------------------------------------------------------------------------- +fromJSVal_Double :: JSVal -> IO (Maybe Double) +fromJSVal_Double x = + if isNullOrUndefined x + then pure Nothing + else Just <$> fromJSValUnchecked_Double x +----------------------------------------------------------------------------- +fromJSVal_List :: JSVal -> IO (Maybe [JSVal]) +fromJSVal_List x = do + if isNullOrUndefined x + then pure Nothing + else do + arrayLike <- isArray x + if not arrayLike + then pure Nothing + else Just <$> fromJSValUnchecked_List x +----------------------------------------------------------------------------- +fromJSValUnchecked_List :: JSVal -> IO [JSVal] +fromJSValUnchecked_List x = do + len <- length x + forM [ 0 .. len - 1 ] (flip getPropIndex_ffi x) +----------------------------------------------------------------------------- +fromJSVal_JSString :: JSVal -> IO (Maybe JSString) +fromJSVal_JSString x = do + if isNullOrUndefined x + then pure Nothing + else Just <$> jsstringFromJSVal x +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + jsstringFromJSVal :: JSVal -> IO JSString +----------------------------------------------------------------------------- +isNullOrUndefined :: JSVal -> Bool +isNullOrUndefined x = isNull_ffi x || isUndefined_ffi x +----------------------------------------------------------------------------- +isUndefined_ffi :: JSVal -> Bool +isUndefined_ffi = isUndefined +----------------------------------------------------------------------------- +isNull_ffi :: JSVal -> Bool +isNull_ffi = isNull +----------------------------------------------------------------------------- +foreign import javascript unsafe "globalThis" + global :: JSVal +----------------------------------------------------------------------------- +-- | Awaits a JS Promise. If the promise rejects, it throws a t'JSException'. +foreign import javascript interruptible "await $1" + await :: JSVal -> IO JSVal +----------------------------------------------------------------------------- +-- The callbacks (asyncCallback, syncCallback, ...) come from GHC.Wasm.Prim. +----------------------------------------------------------------------------- +foreign import javascript unsafe "Object.keys($1)" + listProps_ffi :: JSVal -> IO JSVal +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1.apply($2, $3)" + invokeFunction + :: JSVal + -- ^ Func + -> JSVal + -- ^ Obj + -> JSVal + -- ^ Args + -> IO JSVal + -- ^ Return value +----------------------------------------------------------------------------- +foreign import javascript unsafe "$3[$1]=$2" + setPropIndex_ffi + :: Int + -- ^ Index + -> JSVal + -- ^ Value + -> JSVal + -- ^ Object + -> IO () +----------------------------------------------------------------------------- +foreign import javascript unsafe "$3[$1]=$2" + setProp_ffi + :: JSString + -- ^ Field + -> JSVal + -- ^ Value + -> JSVal + -- ^ Object + -> IO () +----------------------------------------------------------------------------- +foreign import javascript unsafe "new $1(...$2)" + new_ffi + :: JSVal + -- ^ Constructor + -> JSVal + -- ^ Args + -> IO JSVal + -- ^ Return +----------------------------------------------------------------------------- +foreign import javascript unsafe "({})" + create_ffi :: IO JSVal +----------------------------------------------------------------------------- +foreign import javascript unsafe "$2[$1]" + getProp_ffi + :: JSString + -- ^ Key + -> JSVal + -- ^ Value + -> IO JSVal + -- ^ Return +----------------------------------------------------------------------------- +-- | Unsafe JS eval, use at your own risk! You have been warned +foreign import javascript unsafe "eval($1)" + eval_ffi :: JSString -> IO JSVal +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + fromJSValUnchecked_Int :: JSVal -> IO Int +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + fromJSValUnchecked_Double :: JSVal -> IO Double +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1" + fromJSValUnchecked_Bool :: JSVal -> IO Bool +----------------------------------------------------------------------------- +foreign import javascript unsafe "$2[$1]" + getPropIndex_ffi + :: Int + -- ^ Key + -> JSVal + -- ^ Value + -> IO JSVal + -- ^ Return +----------------------------------------------------------------------------- +freeFunction_ffi :: JSVal -> IO () +freeFunction_ffi = freeJSVal +----------------------------------------------------------------------------- +-- | Eagerly release a 'JSVal' handle. See 'Miso.DSL.freeJSVal'. +freeJSVal_ffi :: JSVal -> IO () +freeJSVal_ffi = freeJSVal +----------------------------------------------------------------------------- +foreign import javascript unsafe "requestAnimationFrame($1)" + requestAnimationFrame :: JSVal -> IO Int +----------------------------------------------------------------------------- +-- | High-resolution timestamp where one exists, wall clock where it does not. +foreign import javascript unsafe + "(typeof performance !== 'undefined' && performance && typeof performance.now === 'function') ? performance.now() : Date.now()" + now_ffi :: IO Double +----------------------------------------------------------------------------- +foreign import javascript unsafe "cancelAnimationFrame($1)" + cancelAnimationFrame :: Int -> IO () +----------------------------------------------------------------------------- +foreign import javascript unsafe "Array.isArray($1)" + isArray :: JSVal -> IO Bool +----------------------------------------------------------------------------- +foreign import javascript unsafe "$1.length" + length :: JSVal -> IO Int +----------------------------------------------------------------------------- +fromJSVal_Maybe :: JSVal -> IO (Maybe (Maybe JSVal)) +fromJSVal_Maybe jsval = do + if isNullOrUndefined jsval + then pure (Just Nothing) + else pure $ Just (Just jsval) +----------------------------------------------------------------------------- +fromJSValUnchecked_Maybe :: JSVal -> IO (Maybe JSVal) +fromJSValUnchecked_Maybe jsval = do + if isNullOrUndefined jsval + then pure Nothing + else pure (Just jsval) +----------------------------------------------------------------------------- +-- | Parses like JS's @parseInt@: leading\/trailing whitespace and +-- trailing garbage are ignored, a leading @+\/-@ is allowed, and a +-- @0x@\/@0X@ prefix is read as hexadecimal. +parseInt :: Text -> Maybe Int +parseInt input = applySign <$> digits unsigned + where + stripped = dropWhileEnd isSpace (dropWhile isSpace (T.unpack input)) + (isNegative, unsigned) = case stripped of + ('-' : rest) -> (True, rest) + ('+' : rest) -> (False, rest) + _ -> (False, stripped) + applySign = if isNegative then negate else id + digits ('0' : x : hex) | x == 'x' || x == 'X' = + case readHex hex of + ((n, _) : _) -> Just n + _ -> Nothing + digits ds = + case span (`elem` ['0'..'9']) ds of + ("", _) -> Nothing + (ns, _) -> Just (read ns) +----------------------------------------------------------------------------- +parseWord :: Text -> Maybe Word +parseWord string = fromIntegral <$> parseInt string +----------------------------------------------------------------------------- +-- | Parses like JS's @parseFloat@: leading\/trailing whitespace and +-- trailing garbage are ignored, and a leading @+\/-@ is allowed. +parseDouble :: Text -> Maybe Double +parseDouble input = + case stripped of + ('+' : rest) -> go rest + _ -> go stripped + where + stripped = dropWhile isSpace (T.unpack input) + -- Try successively shorter prefixes, so trailing garbage is ignored. + go s = firstJust [ readMaybe p | p <- reverse (prefixes s) ] + prefixes s = [ take n s | n <- [1 .. L.length s] ] + firstJust (Just x : _) = Just x + firstJust (_ : xs) = firstJust xs + firstJust [] = Nothing +----------------------------------------------------------------------------- +parseFloat :: Text -> Maybe Float +parseFloat string = realToFrac <$> parseDouble string +----------------------------------------------------------------------------- +toString_Int :: Int -> Text +toString_Int = T.pack . show +----------------------------------------------------------------------------- +toString_Double :: Double -> Text +toString_Double = T.pack . show +----------------------------------------------------------------------------- +toString_Float :: Float -> Text +toString_Float = T.pack . show +----------------------------------------------------------------------------- +toString_Word :: Word -> Text +toString_Word = T.pack . show +----------------------------------------------------------------------------- diff --git a/sample-app/Makefile b/sample-app/Makefile index 63fa623e0..5a23d25f9 100644 --- a/sample-app/Makefile +++ b/sample-app/Makefile @@ -54,3 +54,18 @@ build-js86: cp -v ../dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/app-0.1.0.0/x/app/build/app/app.jsexe/all.js . rm -rf public cp -rv static public + +# Build with MicroHs (mhs) for the browser, via emscripten. +# MHS_TARGET is a section of MicroHs's targets.conf: browser (WebAssembly) +# or browser_js (JavaScript only, -sWASM=0). +MHS_TARGET=browser +MHS_FLAGS=-XCPP -DMHS -DMISO_TEXT -i../src -i../ffi/mhs + +mhs: + mkdir -p public-mhs + cp ../js/miso.js public-mhs/ + cp static-mhs/index.html public-mhs/ + mhs $(MHS_FLAGS) -t$(MHS_TARGET) Main -opublic-mhs/app.js + +serve-mhs: + http-server public-mhs diff --git a/sample-app/static-mhs/index.html b/sample-app/static-mhs/index.html new file mode 100644 index 000000000..b52d4d61e --- /dev/null +++ b/sample-app/static-mhs/index.html @@ -0,0 +1,12 @@ + + + + + + sample-app (MicroHs) + + + + + + diff --git a/scripts/playwright-mhs.sh b/scripts/playwright-mhs.sh new file mode 100755 index 000000000..950aab41d --- /dev/null +++ b/scripts/playwright-mhs.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash +# Build the sample app with MicroHs (mhs, emscripten target) and run the +# browser smoke test in ts/playwright-mhs.ts. +# +# Needs on the PATH: mhs (with the emscripten target configured), emcc, node, +# http-server; and the playwright npm package (bun install / npm install) with +# PLAYWRIGHT_BROWSERS_PATH set (e.g. to nixpkgs' playwright-driver.browsers). +# +# Usage: scripts/playwright-mhs.sh [browser|browser_js] (default: browser) +set -euo pipefail +cd "$(dirname "$0")/.." +target="${1:-browser}" +make -C sample-app mhs MHS_TARGET="$target" +http-server sample-app/public-mhs -p 8080 -s & +server=$! +trap 'kill $server 2>/dev/null' EXIT +sleep 1 +NODE_PATH="$PWD/node_modules" node ts/playwright-mhs.ts diff --git a/src/Miso.hs b/src/Miso.hs index 5b19e9673..e25bc4f22 100644 --- a/src/Miso.hs +++ b/src/Miso.hs @@ -1924,6 +1924,11 @@ module Miso , bts , web ) where +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +import Data.Foldable (mapM_, sequence_) +import Data.Traversable (mapM, sequence) +#endif ----------------------------------------------------------------------------- import Miso.DSL import Miso.Effect diff --git a/src/Miso/CSS/Color.hs b/src/Miso/CSS/Color.hs index 771c8dbc4..f93d5367f 100644 --- a/src/Miso/CSS/Color.hs +++ b/src/Miso/CSS/Color.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -251,7 +252,11 @@ import Miso.String (MisoString, ms) import qualified Miso.String as MS ----------------------------------------------------------------------------- import Data.Proxy +#ifdef __MHS__ +import Data.TypeLits +#else import GHC.TypeLits +#endif import GHC.OverloadedLabels import Miso.DSL (ToJSVal(..), ToArgs(..)) import Prelude hiding (tan) diff --git a/src/Miso/Canvas.hs b/src/Miso/Canvas.hs index 1510dd908..ce2d518c3 100644 --- a/src/Miso/Canvas.hs +++ b/src/Miso/Canvas.hs @@ -178,6 +178,9 @@ module Miso.Canvas , color ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (setField) +#endif import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ReaderT, runReaderT, ask) ----------------------------------------------------------------------------- diff --git a/src/Miso/Cookie.hs b/src/Miso/Cookie.hs index d0584eab2..84ac63e7a 100644 --- a/src/Miso/Cookie.hs +++ b/src/Miso/Cookie.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -86,7 +87,12 @@ module Miso.Cookie ) where ----------------------------------------------------------------------------- import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar) +#ifdef __MHS__ +import Control.Monad ((<=<), join) +import Data.Foldable (forM_) +#else import Control.Monad ((<=<), forM_, join) +#endif import Prelude hiding ((!!)) ----------------------------------------------------------------------------- import Miso.DSL diff --git a/src/Miso/DSL.hs b/src/Miso/DSL.hs index aa3b16a25..1741f0583 100644 --- a/src/Miso/DSL.hs +++ b/src/Miso/DSL.hs @@ -112,9 +112,13 @@ module Miso.DSL ( -- * Classes ToJSVal (..) +#ifndef __MHS__ , GToJSVal (..) +#endif , FromJSVal (..) +#ifndef __MHS__ , GFromJSVal (..) +#endif , ToArgs (..) , ToObject (..) -- * Types @@ -173,14 +177,28 @@ import Control.Applicative #ifndef VANILLA import Data.Text (Text) #endif +#ifdef __MHS__ +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM, sequence) +#else import Control.Monad +#endif import Control.Monad.Trans.Maybe import qualified Data.Map.Strict as M import Data.Map.Strict (Map) import GHC.Generics import GHC.TypeLits import Data.Kind +#ifdef __MHS__ +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_, setField, (!!)) +#else +import Prelude hiding (setField, (!!)) +#endif +#else import Prelude hiding ((!!)) +#endif ----------------------------------------------------------------------------- import Miso.DSL.FFI import Miso.JSON (Value, fromJSVal_Value, toJSVal_Value) @@ -189,12 +207,15 @@ import Miso.String -- | A class for marshaling Haskell values into JS class ToJSVal a where toJSVal :: a -> IO JSVal +#ifndef __MHS__ default toJSVal :: (Generic a, GToJSVal (Rep a)) => a -> IO JSVal toJSVal x = do o <- create gToJSVal (from x) o toJSVal o +#endif ----------------------------------------------------------------------------- +#ifndef __MHS__ -- | Internal: writes a t'GHC.Generics.Generic' representation into a JS object -- field by field. Backs the default 'ToJSVal' implementation; you should not -- need to write instances. @@ -213,7 +234,11 @@ instance (GToJSVal a, GToJSVal b) => GToJSVal (a :*: b) where gToJSVal (x :*: y) o = gToJSVal x o >> gToJSVal y o {-# INLINE gToJSVal #-} ----------------------------------------------------------------------------- +#ifdef __MHS__ +instance (GToJSVal a, GToJSVal b) => GToJSVal (a :+: b) where +#else instance (TypeError ('Text "Sum types unsupported"), GToJSVal a, GToJSVal b) => GToJSVal (a :+: b) where +#endif gToJSVal = \case L1 x -> gToJSVal x R1 x -> gToJSVal x @@ -233,6 +258,7 @@ instance GToJSVal U1 where instance GToJSVal V1 where gToJSVal _ _ = pure () {-# INLINE gToJSVal #-} +#endif ----------------------------------------------------------------------------- instance ToJSVal Bool where toJSVal = toJSVal_Bool @@ -318,14 +344,17 @@ instance FromJSVal Value where -- | A class for marshaling JS values into Haskell class FromJSVal a where fromJSVal :: JSVal -> IO (Maybe a) +#ifndef __MHS__ default fromJSVal :: (Generic a, GFromJSVal (Rep a)) => JSVal -> IO (Maybe a) fromJSVal x = fmap to <$> gFromJSVal (Object x) +#endif fromJSValUnchecked :: JSVal -> IO a fromJSValUnchecked x = do fromJSVal x >>= \case Nothing -> error "fromJSValUnchecked: failure" Just y -> pure y ----------------------------------------------------------------------------- +#ifndef __MHS__ -- | Internal: rebuilds a t'GHC.Generics.Generic' representation from a JS -- object, yielding 'Nothing' when a field is missing or ill-typed. Backs the -- default 'FromJSVal' implementation. @@ -352,7 +381,11 @@ instance (GFromJSVal a, GFromJSVal b) => GFromJSVal (a :*: b) where gFromJSVal o = runMaybeT $ (:*:) <$> MaybeT (gFromJSVal o) <*> MaybeT (gFromJSVal o) {-# INLINE gFromJSVal #-} ----------------------------------------------------------------------------- +#ifdef __MHS__ +instance (GFromJSVal a, GFromJSVal b) => GFromJSVal (a :+: b) where +#else instance (TypeError ('Text "Sum types unsupported"), GFromJSVal a, GFromJSVal b) => GFromJSVal (a :+: b) where +#endif gFromJSVal o = do x <- fmap L1 <$> gFromJSVal o case x of @@ -365,6 +398,7 @@ instance (FromJSVal a, Selector s) => GFromJSVal (S1 s (K1 i a)) where where name = selName (undefined :: S1 s (K1 i a) ()) {-# INLINE gFromJSVal #-} +#endif ----------------------------------------------------------------------------- instance FromJSVal Int where fromJSVal = fromJSVal_Int @@ -784,11 +818,13 @@ instance ToObject JSVal where -- | A class for creating JS objects. class ToObject a where toObject :: a -> IO Object +#ifndef __MHS__ default toObject :: (Generic a, GToJSVal (Rep a)) => a -> IO Object toObject x = do o <- create gToJSVal (from x) o pure o +#endif ----------------------------------------------------------------------------- instance ToJSVal a => ToObject (IO a) where toObject action = Object <$> (toJSVal =<< action) diff --git a/src/Miso/Data/Array.hs b/src/Miso/Data/Array.hs index f3d2aa2bb..43b592f53 100644 --- a/src/Miso/Data/Array.hs +++ b/src/Miso/Data/Array.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -80,8 +81,20 @@ module Miso.Data.Array , reverse ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Control.Monad (void) +import Data.Foldable (forM_) +import Data.Traversable (forM) +#else import Control.Monad (void, forM, forM_) +#endif +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_, lookup, null, reverse) +import Data.Foldable (mapM_, sequence_) +import Data.Traversable (mapM, sequence) +#else import Prelude hiding (lookup, null, reverse) +#endif ----------------------------------------------------------------------------- import Miso.DSL (jsg, JSVal, ToObject, ToJSVal, FromJSVal, (!)) import qualified Miso.DSL as DSL diff --git a/src/Miso/Data/Map.hs b/src/Miso/Data/Map.hs index ca59c8b00..31b3ff3cc 100644 --- a/src/Miso/Data/Map.hs +++ b/src/Miso/Data/Map.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -73,7 +74,12 @@ module Miso.Data.Map , delete ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Control.Monad (void) +import Data.Foldable (forM_) +#else import Control.Monad (void, forM_) +#endif import Prelude hiding (lookup) ----------------------------------------------------------------------------- import Miso.DSL (jsg, JSVal, ToJSVal, FromJSVal, (!)) diff --git a/src/Miso/Data/Set.hs b/src/Miso/Data/Set.hs index c7ada7dd5..b77db8b4c 100644 --- a/src/Miso/Data/Set.hs +++ b/src/Miso/Data/Set.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -81,7 +82,12 @@ module Miso.Data.Set , isDisjoint ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Control.Monad (void) +import Data.Foldable (forM_) +#else import Control.Monad (void, forM_) +#endif import Prelude hiding (lookup) ----------------------------------------------------------------------------- import Miso.DSL (jsg, JSVal, ToJSVal, FromJSVal, (!)) diff --git a/src/Miso/Effect.hs b/src/Miso/Effect.hs index 4ef4e6eda..da49ca882 100644 --- a/src/Miso/Effect.hs +++ b/src/Miso/Effect.hs @@ -148,6 +148,11 @@ module Miso.Effect , runOnBG , runOnMain ) where +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +import Data.Foldable (mapM_, sequence_) +import Data.Traversable (mapM, sequence) +#endif ----------------------------------------------------------------------------- import Control.Monad (void) import Data.Foldable (traverse_) diff --git a/src/Miso/Event.hs b/src/Miso/Event.hs index ae1cc5d23..a50aeeb7f 100644 --- a/src/Miso/Event.hs +++ b/src/Miso/Event.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -47,6 +48,11 @@ module Miso.Event , module Miso.Event.Decoder , module Miso.Event.Types ) where +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +import Data.Foldable (mapM_, sequence_) +import Data.Traversable (mapM, sequence) +#endif ----------------------------------------------------------------------------- import Control.Monad (when) import qualified Data.Map.Strict as M diff --git a/src/Miso/Event/Types.hs b/src/Miso/Event/Types.hs index 0fb6da077..c0a5805eb 100644 --- a/src/Miso/Event/Types.hs +++ b/src/Miso/Event/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -88,6 +89,11 @@ module Miso.Event.Types , clipboardEvents , touchEvents ) where +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +import Data.Foldable (mapM_, sequence_) +import Data.Traversable (mapM, sequence) +#endif ----------------------------------------------------------------------------- import Miso.JSON (FromJSON(..), withText) import qualified Data.Map.Strict as M diff --git a/src/Miso/FFI/Internal.hs b/src/Miso/FFI/Internal.hs index de58dc952..f0b3adf62 100644 --- a/src/Miso/FFI/Internal.hs +++ b/src/Miso/FFI/Internal.hs @@ -230,10 +230,19 @@ module Miso.FFI.Internal , getRandomValue ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Control.Monad (void, (<=<), when, unless) +import Data.Foldable (forM_) +#else import Control.Monad (void, forM_, (<=<), when, unless) +#endif import Data.Map.Strict (Map) import Data.Maybe +#ifdef __MHS__ +import Prelude hiding (setField, (!!)) +#else import Prelude hiding ((!!)) +#endif ----------------------------------------------------------------------------- import Miso.DSL import Miso.String diff --git a/src/Miso/FFI/QQ.hs b/src/Miso/FFI/QQ.hs index aea3ba192..0d2b11899 100644 --- a/src/Miso/FFI/QQ.hs +++ b/src/Miso/FFI/QQ.hs @@ -92,9 +92,18 @@ module Miso.FFI.QQ ( js ) where ---------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +#endif import Control.Applicative import Data.Data +#ifdef __MHS__ +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM, sequence) +#else import Control.Monad +#endif import System.IO.Unsafe (unsafePerformIO) import Language.Haskell.TH.Lib import Language.Haskell.TH.Quote diff --git a/src/Miso/Html/Render.hs b/src/Miso/Html/Render.hs index de7eb02de..4ead9035e 100644 --- a/src/Miso/Html/Render.hs +++ b/src/Miso/Html/Render.hs @@ -97,6 +97,11 @@ module Miso.Html.Render -- *** Functions , toHtmlWith ) where +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +import Data.Foldable (mapM_, sequence_) +import Data.Traversable (mapM, sequence) +#endif ---------------------------------------------------------------------------- import qualified Data.Set as S import Data.Set (Set) diff --git a/src/Miso/JSON.hs b/src/Miso/JSON.hs index 86e309f7c..37d1df2a1 100644 --- a/src/Miso/JSON.hs +++ b/src/Miso/JSON.hs @@ -188,7 +188,7 @@ module Miso.JSON , Options (..) , defaultOptions -- * Generics -#ifndef AESON +#if !defined(AESON) && !defined(__MHS__) , GToJSON (..) , GToFields (..) , GToJSONRep (..) @@ -202,17 +202,28 @@ module Miso.JSON , GFromJSONSum (..) , GFromJSONSumNullary (..) #endif +#ifndef __MHS__ , genericToJSON , genericParseJSON +#endif -- * Modifiers , camelTo2 ) where ---------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +#endif #ifdef GHCJS_BOTH import qualified GHCJS.Marshal as Marshal #endif ---------------------------------------------------------------------------- +#ifdef __MHS__ +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM, sequence) +#else import Control.Monad +#endif #if __GLASGOW_HASKELL__ <= 865 import Control.Monad.Fail import GHC.Natural (Natural) @@ -376,8 +387,10 @@ instance FromJSONKey MisoString where class ToJSON a where -- | Convert a value to a JSON 'Value'. toJSON :: a -> Value +#ifndef __MHS__ default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value toJSON = genericToJSON defaultOptions +#endif -- | Encode a list of @a@. Defaults to a JSON 'Array'; overridden by the -- 'Char' instance so that @[Char]@ (i.e. t'String') serializes as a JSON @@ -385,6 +398,7 @@ class ToJSON a where toJSONList :: [a] -> Value toJSONList = Array . Prelude.map toJSON ---------------------------------------------------------------------------- +#ifndef __MHS__ -- | Derive 'toJSON' via 'GHC.Generics' with custom t'Options'. -- Called by the default 'ToJSON' implementation using 'defaultOptions'. genericToJSON @@ -395,6 +409,7 @@ genericToJSON -- ^ Value to encode -> Value genericToJSON opts = gToJSON opts . from +#endif ---------------------------------------------------------------------------- -- | Configuration for generic JSON encoding and decoding via 'genericToJSON' -- and 'genericParseJSON'. Mirrors the subset of aeson's @Options@ that is @@ -455,6 +470,7 @@ camelTo2 c = Prelude.map toLower . go2 . go1 go2 (l:u:xs) | isLower l && isUpper u = l : c : u : go2 xs go2 (x:xs) = x : go2 xs ---------------------------------------------------------------------------- +#ifndef __MHS__ -- | Intermediate representation of a constructor's fields after encoding. -- -- 'RecordFields' is produced when every selector has a name (record syntax); @@ -624,6 +640,7 @@ instance (Constructor m, GToFields f) => GToJSONSum (C1 m f) where encodeTaggedCon (ms (constructorTagModifier opts (conName (undefined :: C1 m f ())))) (gToFields opts x) +#endif ---------------------------------------------------------------------------- instance ToJSON () where toJSON () = Array [] @@ -789,9 +806,12 @@ class FromJSON a where -- | Parse a JSON 'Value' into @a@, failing with a descriptive error message -- via t'Parser' on a type mismatch. parseJSON :: Value -> Parser a +#ifndef __MHS__ default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a parseJSON = genericParseJSON defaultOptions +#endif ---------------------------------------------------------------------------- +#ifndef __MHS__ -- | Top-level generic decoding class. Symmetric with 'GToJSON'. -- -- Decoding rules match aeson's defaults (see t'Options' and 'defaultOptions'). @@ -957,6 +977,7 @@ instance {-# OVERLAPPABLE #-} (Selector m, FromJSON a) gFromPositional _ vs = case vs of (v:_) -> M1 . K1 <$> parseJSON v [] -> pfail "gFromPositional: unexpected end of fields" +#endif ---------------------------------------------------------------------------- instance FromJSON Value where parseJSON = pure @@ -1081,7 +1102,7 @@ instance FromJSON Char where | otherwise -> pfail ("expected Char, received: " <> x) ---------------------------------------------------------------------------- instance FromJSON v => FromJSON (Map MisoString v) where - parseJSON = withObject "FromJSON v => Map MisoString v" $ mapM parseJSON + parseJSON = withObject "FromJSON v => Map MisoString v" $ traverse parseJSON #endif ---------------------------------------------------------------------------- #ifdef AESON @@ -1335,7 +1356,7 @@ foreign import javascript unsafe encodePretty_ffi :: JSVal -> Int -> IO MisoString #endif ----------------------------------------------------------------------------- -#ifdef WASM +#if defined(WASM) || defined(MHS) #ifdef MISO_TEXT foreign import javascript unsafe "return JSON.stringify($1, null, $2);" @@ -1393,7 +1414,7 @@ foreign import javascript unsafe jsonStringify :: JSVal -> IO MisoString #endif ----------------------------------------------------------------------------- -#ifdef WASM +#if defined(WASM) || defined(MHS) #ifdef MISO_TEXT foreign import javascript unsafe "return JSON.stringify($1);" @@ -1425,7 +1446,7 @@ foreign import javascript unsafe jsonParse :: MisoString -> IO JSVal #endif ----------------------------------------------------------------------------- -#ifdef WASM +#if defined(WASM) || defined(MHS) #ifdef MISO_TEXT foreign import javascript unsafe "return JSON.parse($1);" @@ -1574,7 +1595,7 @@ fromJSVal_Value jsval_ = do toObject = mkObject #endif ----------------------------------------------------------------------------- -#ifdef WASM +#if defined(WASM) || defined(MHS) fromJSVal_Value :: JSVal -> IO (Maybe Value) fromJSVal_Value jsval = do typeof jsval >>= \case @@ -1630,7 +1651,7 @@ foreign import javascript unsafe typeof :: JSVal -> IO Int #endif ----------------------------------------------------------------------------- -#ifdef WASM +#if defined(WASM) || defined(MHS) foreign import javascript unsafe "return globalThis.miso.typeOf($1);" typeof :: JSVal -> IO Int @@ -1642,7 +1663,7 @@ foreign import javascript unsafe typeof :: JSVal -> IO Int #endif ----------------------------------------------------------------------------- -#ifdef WASM +#if defined(WASM) || defined(MHS) -- | Convert a Miso JSON t'Value' to a raw JavaScript value via FFI. toJSVal_Value :: Value -> IO JSVal toJSVal_Value = \case diff --git a/src/Miso/JSON/Lexer.hs b/src/Miso/JSON/Lexer.hs index f7fab0718..8319bb3f6 100644 --- a/src/Miso/JSON/Lexer.hs +++ b/src/Miso/JSON/Lexer.hs @@ -54,7 +54,13 @@ import Data.Functor (void) import Data.Ix (Ix (inRange)) import Data.Maybe (catMaybes) import Numeric (readHex) +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_, null) +import Data.Foldable (mapM_, sequence_) +import Data.Traversable (mapM, sequence) +#else import Prelude hiding (null) +#endif ---------------------------------------------------------------------------- import Miso.String (fromMisoString, ToMisoString (toMisoString), MisoString) import Miso.Util (oneOf) @@ -100,6 +106,7 @@ string' = char '"' *> (toMisoString <$> many character) <* char '"' , escapedCharacter ] hexDigit = satisfy isHexDigit + escaped :: Lexer a -> Lexer a escaped = (char '\\' *>) escapedCharacter = escaped $ oneOf [ char '"' @@ -125,8 +132,10 @@ string' = char '"' *> (toMisoString <$> many character) <* char '"' else pure $ chr high ] + highSurrogateRange, lowSurrogateRange :: (Int, Int) highSurrogateRange = (0xD800, 0xDBFF) lowSurrogateRange = (0xDC00, 0xDFFF) + unicodeHexQuad :: Lexer Int unicodeHexQuad = char 'u' *> do [(num, "")] <- readHex <$> replicateM 4 hexDigit pure num diff --git a/src/Miso/Lens.hs b/src/Miso/Lens.hs index 4c03bb78b..908ee07d1 100644 --- a/src/Miso/Lens.hs +++ b/src/Miso/Lens.hs @@ -847,32 +847,51 @@ prism = Prism -- > at 10 ?= value -- -- @since 1.9.0.0 +#ifndef __MHS__ class At at where type family Index at :: Type -- ^ Index of the container type family IxValue at :: Type -- ^ Indexed value of the container at :: Index at -> Lens at (Maybe (IxValue at)) ----------------------------------------------------------------------------- +#else +-- MicroHs has no associated type families, so the index and value types are +-- class parameters determined by the container type. +class At at k v | at -> k, at -> v where + at :: k -> Lens at (Maybe v) +#endif +---------------------------------------------------------------------------- +#ifndef __MHS__ instance Ord k => At (Map k v) where type Index (Map k v) = k type IxValue (Map k v) = v +#else +instance Ord k => At (Map k v) k v where +#endif at key = lens (M.lookup key) $ \m value -> case value of Nothing -> M.delete key m Just v -> M.insert key v m ---------------------------------------------------------------------------- +#ifndef __MHS__ instance At (IntMap v) where type Index (IntMap v) = Int type IxValue (IntMap v) = v +#else +instance At (IntMap v) Int v where +#endif at key = lens (IM.lookup key) $ \m value -> case value of Nothing -> IM.delete key m Just v -> IM.insert key v m ---------------------------------------------------------------------------- +#ifndef __MHS__ instance Ord k => At (Set k) where type Index (Set k) = k type IxValue (Set k) = () +#else +instance Ord k => At (Set k) k () where +#endif at key = Lens {..} where _set = \v m -> @@ -883,9 +902,13 @@ instance Ord k => At (Set k) where | S.member key m = Just () | otherwise = Nothing ---------------------------------------------------------------------------- +#ifndef __MHS__ instance At IntSet where type Index IntSet = Int type IxValue IntSet = () +#else +instance At IntSet Int () where +#endif at key = Lens {..} where _set = \v m -> @@ -896,9 +919,13 @@ instance At IntSet where | IS.member key m = Just () | otherwise = Nothing ---------------------------------------------------------------------------- +#ifndef __MHS__ instance At [a] where type Index [a] = Int type IxValue [a] = a +#else +instance At [a] Int a where +#endif at key = Lens {..} where _set Nothing m diff --git a/src/Miso/Lens/TH.hs b/src/Miso/Lens/TH.hs index 93a844a5d..841ae71fa 100644 --- a/src/Miso/Lens/TH.hs +++ b/src/Miso/Lens/TH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskellQuotes #-} @@ -86,6 +87,11 @@ module Miso.Lens.TH , this , Lens ) where +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +import Data.Foldable (mapM_, sequence_) +import Data.Traversable (mapM, sequence) +#endif ----------------------------------------------------------------------------- import Data.Char import Data.Maybe diff --git a/src/Miso/Media.hs b/src/Miso/Media.hs index fb8d182b7..8075b7c50 100644 --- a/src/Miso/Media.hs +++ b/src/Miso/Media.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -119,7 +120,20 @@ module Miso.Media , mediaEvents ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_, setField) +#else +import Prelude hiding (setField) +#endif +#endif +#ifdef __MHS__ +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM, sequence) +#else import Control.Monad +#endif ----------------------------------------------------------------------------- import Miso.DSL import Miso.Event diff --git a/src/Miso/Native/FFI.hs b/src/Miso/Native/FFI.hs index 314031801..f0d2e0f61 100644 --- a/src/Miso/Native/FFI.hs +++ b/src/Miso/Native/FFI.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- @@ -19,7 +20,16 @@ module Miso.Native.FFI , enableDebugging ) where ---------------------------------------------------------------------------- +#ifdef __MHS__ +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +#endif +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM, sequence) +#else import Control.Monad +#endif ----------------------------------------------------------------------------- import Miso ----------------------------------------------------------------------------- diff --git a/src/Miso/Native/MainThread.hs b/src/Miso/Native/MainThread.hs index 3f46a52b1..19ef6adf9 100644 --- a/src/Miso/Native/MainThread.hs +++ b/src/Miso/Native/MainThread.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} @@ -73,7 +74,12 @@ module Miso.Native.MainThread , modifyMainThreadRef_ ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Control.Monad (void) +import Data.Foldable (forM_) +#else import Control.Monad (void, forM_) +#endif import Control.Monad.State (State, execState) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef') import System.IO.Unsafe (unsafePerformIO) diff --git a/src/Miso/Reload.hs b/src/Miso/Reload.hs index cfc707d17..35a4943d8 100644 --- a/src/Miso/Reload.hs +++ b/src/Miso/Reload.hs @@ -68,8 +68,17 @@ module Miso.Reload , liveWithContext ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (setField, mapM, mapM_, sequence, sequence_) +import Control.Concurrent +-- MicroHs's Control.Monad traversals are list-only +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM) +#else import Control.Concurrent import Control.Monad +#endif ----------------------------------------------------------------------------- import Miso.DSL ((!), jsg, setField) import qualified Miso.FFI.Internal as FFI diff --git a/src/Miso/Router.hs b/src/Miso/Router.hs index d1dfdd96b..07502473c 100644 --- a/src/Miso/Router.hs +++ b/src/Miso/Router.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -106,7 +107,9 @@ module Miso.Router ( -- ** Classes Router (..) , RouteParser +#ifndef __MHS__ , GRouter (..) +#endif -- ** Types , Capture (..) , Path (..) @@ -140,6 +143,9 @@ module Miso.Router , tokensToURI ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +#endif import qualified Data.Map.Strict as M import Data.Maybe import Data.Bifunctor (first) @@ -148,9 +154,19 @@ import Data.Proxy import qualified Data.Char as C import Data.String import Control.Applicative +#ifdef __MHS__ +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM, sequence) +#else import Control.Monad +#endif import GHC.Generics +#ifdef __MHS__ +import Data.TypeLits +#else import GHC.TypeLits +#endif ----------------------------------------------------------------------------- import Miso.Types hiding (model, fragment, fragment_) import Miso.JSON (FromJSON (..)) @@ -345,8 +361,10 @@ instance FromJSON URI where -- | Class used to facilitate routing for miso applications class Router route where fromRoute :: route -> [Token] +#ifndef __MHS__ default fromRoute :: (Generic route, GRouter (Rep route)) => route -> [Token] fromRoute = gFromRoute . from +#endif -- | Convert a 'Router route => route' into a t'URI' toURI :: route -> URI @@ -373,8 +391,10 @@ class Router route where toRoute input = parseRoute input routeParser routeParser :: RouteParser route +#ifndef __MHS__ default routeParser :: (Generic route, GRouter (Rep route)) => RouteParser route routeParser = to <$> gRouteParser +#endif ----------------------------------------------------------------------------- -- | Smart constructor for building a @RouteParser@ -- @@ -405,6 +425,7 @@ runRouter = parseRoute routes :: [ RouteParser route ] -> RouteParser route routes = foldr (<|>) empty ----------------------------------------------------------------------------- +#ifndef __MHS__ -- | Generic deriving for 'Router' class GRouter f where gFromRoute :: f route -> [Token] @@ -460,6 +481,7 @@ instance {-# OVERLAPS #-} forall param m a . (ToMisoString a, FromMisoString a, Nothing -> [QueryParamToken key Nothing] Just v -> [QueryParamToken key (Just (ms v))] gRouteParser = K1 <$> queryParam +#endif ----------------------------------------------------------------------------- -- | Query parameter parser from a route queryParam @@ -475,6 +497,7 @@ queryParam = do Right parsed -> pure (Just parsed) _ -> pure Nothing ----------------------------------------------------------------------------- +#ifndef __MHS__ instance {-# OVERLAPS #-} forall flag m . KnownSymbol flag => GRouter (K1 m (QueryFlag flag)) where gFromRoute (K1 (QueryFlag specified)) | specified = [ QueryParamToken flag Nothing ] @@ -482,6 +505,7 @@ instance {-# OVERLAPS #-} forall flag m . KnownSymbol flag => GRouter (K1 m (Que where flag = ms (symbolVal (Proxy @flag)) gRouteParser = K1 <$> queryFlag +#endif ----------------------------------------------------------------------------- -- | Query flag parser from a route queryFlag :: forall flag . KnownSymbol flag => RouteParser (QueryFlag flag) @@ -491,6 +515,7 @@ queryFlag = do where flag = ms $ symbolVal (Proxy @flag) ----------------------------------------------------------------------------- +#ifndef __MHS__ instance Router a => GRouter (K1 m a) where gFromRoute (K1 x) = fromRoute x gRouteParser = K1 <$> routeParser @@ -511,6 +536,7 @@ instance (GRouter left, GRouter right) => GRouter (left :+: right) where [ L1 <$> gRouteParser , R1 <$> gRouteParser ] +#endif ----------------------------------------------------------------------------- captureOrPathToken :: RouteParser Token captureOrPathToken = satisfy $ \case diff --git a/src/Miso/Runtime.hs b/src/Miso/Runtime.hs index bf1243e46..5cf0d2dcb 100644 --- a/src/Miso/Runtime.hs +++ b/src/Miso/Runtime.hs @@ -130,7 +130,15 @@ import Data.Proxy (Proxy(Proxy)) import Control.Category ((.)) import Control.Concurrent import Control.Exception (SomeException, catch) +#ifdef __MHS__ +-- MicroHs's Prelude/Control.Monad mapM, mapM_, forM, forM_ are list-only, +-- the Foldable/Traversable ones are in Data.Foldable and Data.Traversable +import Control.Monad (when, void, (<=<), zipWithM_, forever, foldM, unless) +import Data.Foldable (Foldable(..), forM_, mapM_, sequence_, traverse_, for_, concat, concatMap, and, or, any, all, notElem, find) +import Data.Traversable (forM, mapM, traverse, for) +#else import Control.Monad (forM, forM_, when, void, (<=<), zipWithM_, forever, foldM, unless) +#endif import Control.Monad.Reader (ask, asks) import Control.Monad.State hiding (state) import qualified Miso.JSON as JSON @@ -149,7 +157,11 @@ import qualified Data.IntMap.Strict as IM import Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef, atomicWriteIORef) import qualified Data.Sequence as S import Data.Sequence (Seq) +#ifdef __MHS__ +import Control.Concurrent (ThreadStatus(ThreadDied, ThreadFinished), threadStatus) +#else import GHC.Conc (ThreadStatus(ThreadDied, ThreadFinished), threadStatus) +#endif import Data.Word (Word64) import GHC.Fingerprint (Fingerprint(..)) import Numeric (readHex) @@ -157,10 +169,18 @@ import GHC.StaticPtr (StaticKey, staticKey, deRefStaticPtr) #ifdef NATIVE import GHC.StaticPtr (unsafeLookupStaticPtr) #endif +#ifdef __MHS__ +import Prelude hiding (setField, (.), mapM, mapM_, sequence, sequence_, null, length, elem, notElem, sum, product, maximum, minimum, foldr, foldl, foldr1, foldl1, concat, concatMap, and, or, any, all) +#else import Prelude hiding ((.)) +#endif import System.IO.Unsafe (unsafePerformIO) +#ifdef __MHS__ +import System.Mem (performGC) +#else import System.Mem.StableName (makeStableName) import System.Mem (performMajorGC) +#endif #ifdef BENCH import Text.Printf #endif @@ -391,10 +411,15 @@ mkGetModel vcompId initialModel = do -- and a redraw / propagation is necessary. Pointer equality via 'StableName' -- is used as a fast path before falling back to 'Eq'. dirtyCheck :: Eq a => a -> a -> Bool +#ifdef __MHS__ +-- MicroHs has no stable names, so only the structural comparison is done. +dirtyCheck c n = c /= n +#else dirtyCheck c n = unsafePerformIO $ do currentName <- c `seq` makeStableName c updatedName <- n `seq` makeStableName n pure (currentName /= updatedName && c /= n) +#endif ----------------------------------------------------------------------------- -- | Checks if the Component is mounted before executing actions isMounted :: ComponentId -> IO Bool @@ -662,7 +687,7 @@ dequeue q = (process, rest) -> do let updated = q & queueSchedule .~ remaining - & queue.at vcompId .~ do if null rest then Nothing else Just rest + & queue . at vcompId .~ do if null rest then Nothing else Just rest Just (vcompId, process, updated) ----------------------------------------------------------------------------- -- | Dequeues everything from the Queue at a specific @ComponentId@, draining @@ -678,7 +703,7 @@ dequeueAt vcompId q = Just actions -> do -- dmj: remove from schedule, extract all events let updated = q & queueSchedule %~ S.filter (/=vcompId) - & queue.at vcompId .~ Nothing + & queue . at vcompId .~ Nothing (updated, actions) ----------------------------------------------------------------------------- globalWaiter :: Waiter @@ -1148,7 +1173,11 @@ cleanup Proxy live domRef = do unless isnull $ do void $ (domRef # "abort") () yield +#ifdef __MHS__ + performGC +#else performMajorGC +#endif ----------------------------------------------------------------------------- -- | componentMap -- @@ -1236,7 +1265,7 @@ unmountComponent cs@ComponentState {..} = do freeLifecycleHooks cs freeEventHandlers _componentId modifyComponent _componentParentId $ do - children.at _componentId .= Nothing + children . at _componentId .= Nothing atomicModifyIORef' components $ \m -> (IM.delete _componentId m, ()) #ifdef NATIVE when bts $ do diff --git a/src/Miso/Subscription/Cookie.hs b/src/Miso/Subscription/Cookie.hs index dc88a1520..6a9831c24 100644 --- a/src/Miso/Subscription/Cookie.hs +++ b/src/Miso/Subscription/Cookie.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- @@ -56,6 +57,11 @@ module Miso.Subscription.Cookie ( -- ** Subscriptions cookieChangeSub ) where +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +import Data.Foldable (mapM_, sequence_) +import Data.Traversable (mapM, sequence) +#endif ----------------------------------------------------------------------------- import Miso.Cookie (CookieChangeEvent) import Miso.DSL (fromJSVal) diff --git a/src/Miso/Subscription/History.hs b/src/Miso/Subscription/History.hs index e90e5b4d9..b279fa20c 100644 --- a/src/Miso/Subscription/History.hs +++ b/src/Miso/Subscription/History.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- @@ -78,7 +79,16 @@ module Miso.Subscription.History , URI (..) ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +#endif +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM, sequence) +#else import Control.Monad +#endif ----------------------------------------------------------------------------- import Miso.DSL import qualified Miso.FFI.Internal as FFI diff --git a/src/Miso/Subscription/Window.hs b/src/Miso/Subscription/Window.hs index 39e9a07db..9c05e550c 100644 --- a/src/Miso/Subscription/Window.hs +++ b/src/Miso/Subscription/Window.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} @@ -72,13 +73,22 @@ module Miso.Subscription.Window , Coord ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +#endif +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM, sequence) +#else import Control.Monad +#endif ----------------------------------------------------------------------------- import Miso.DSL import Miso.Event import Miso.Effect import qualified Miso.FFI.Internal as FFI -import Miso.JSON hiding (Options, defaultOptions) +import Miso.JSON hiding (Options(..), defaultOptions) import Miso.String import Miso.Subscription.Util import Miso.Canvas (Coord) diff --git a/src/Miso/Util/Lexer.hs b/src/Miso/Util/Lexer.hs index b293d177e..4bd2eb5be 100644 --- a/src/Miso/Util/Lexer.hs +++ b/src/Miso/Util/Lexer.hs @@ -100,7 +100,16 @@ module Miso.Util.Lexer , withLocation ) where ---------------------------------------------------------------------------- +#ifdef __MHS__ +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +#endif +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM, sequence) +#else import Control.Monad +#endif #if __GLASGOW_HASKELL__ <= 865 import Control.Monad.Fail #endif diff --git a/src/Miso/Util/Parser.hs b/src/Miso/Util/Parser.hs index 3bb515d87..f00ca6b9e 100644 --- a/src/Miso/Util/Parser.hs +++ b/src/Miso/Util/Parser.hs @@ -97,11 +97,20 @@ module Miso.Util.Parser , endOfInput ) where ---------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +#endif #if __GLASGOW_HASKELL__ <= 881 import Control.Monad.Fail (MonadFail (..)) #endif import Control.Applicative +#ifdef __MHS__ +import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) +import Data.Foldable (forM_, mapM_, sequence_) +import Data.Traversable (forM, mapM, sequence) +#else import Control.Monad +#endif import Data.Maybe (isNothing) ---------------------------------------------------------------------------- import Miso.Util.Lexer (LexerError) diff --git a/ts/playwright-mhs.ts b/ts/playwright-mhs.ts new file mode 100644 index 000000000..e3ae89476 --- /dev/null +++ b/ts/playwright-mhs.ts @@ -0,0 +1,31 @@ +// Browser smoke test for the sample app built with MicroHs (see scripts/playwright-mhs.sh). +// Loads the page served on port 8080, clicks the counter buttons, and prints +// SUCCESS or ERROR (the same protocol as playwright.ts). +const { chromium } = require('playwright'); + +(async () => { + const browser = await chromium.launch({ headless: true }); + const page = await browser.newPage(); + page.on('console', (msg) => console.log('[console:' + msg.type() + '] ' + msg.text())); + page.on('pageerror', (err) => console.log('[pageerror] ' + err.message)); + await page.goto('http://127.0.0.1:8080'); + try { + await page.waitForSelector('button', { timeout: 20000 }); + const text = async () => (await page.locator('body').innerText()).replace(/\s+/g, ''); + const before = await text(); + await page.getByText('+', { exact: true }).click(); + await page.getByText('+', { exact: true }).click(); + await page.getByText('-', { exact: true }).click(); + await page.waitForTimeout(300); + const after = await text(); + console.log(`before: ${before}, after: ${after}`); + const ok = before.includes('+0-') && after.includes('+1-'); + console.log(ok ? 'SUCCESS' : 'ERROR'); + await browser.close(); + process.exit(ok ? 0 : 1); + } catch (e) { + console.log('ERROR ' + e.message); + await browser.close(); + process.exit(1); + } +})(); From 0c2827e28c966471af9b3f223978c2adfcc22b06 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sun, 20 Sep 2026 10:08:44 -0500 Subject: [PATCH 02/34] mhs: build with mcabal, embed miso.js via js-sources Add impl(mhs) arms to miso.cabal (cpp-options, ffi/mhs, js-sources, Miso.Lens.Generic excluded since MicroHs has no type families), so the library installs with 'mcabal install' and executables build with 'mcabal --options=-tbrowser build' with miso.js embedded. The sample-app 'make mhs' target now embeds js/miso.js with -js instead of loading it with a script tag, and 'make mhs-mcabal' builds via mcabal. Miso.Lens gets the CPP pragma it needs (mcabal only passes -XCPP when the cabal file asks for it), and the playwright smoke test script is an ES module, as node treats miso's ts files. --- miso.cabal | 19 +++++++++++++++++-- sample-app/Makefile | 11 +++++++++-- sample-app/static-mhs/index.html | 1 - src/Miso/Lens.hs | 1 + ts/playwright-mhs.ts | 2 +- 5 files changed, 28 insertions(+), 6 deletions(-) diff --git a/miso.cabal b/miso.cabal index 9b5638725..0fe880eb3 100644 --- a/miso.cabal +++ b/miso.cabal @@ -41,6 +41,9 @@ common cpp elif arch(wasm32) cpp-options: -DWASM + elif impl(mhs) + cpp-options: + -DMHS -DMISO_TEXT else cpp-options: -DVANILLA @@ -66,7 +69,7 @@ common cpp -DMISO_TEXT common client - if impl(ghcjs) || arch(javascript) || arch(wasm32) + if impl(ghcjs) || arch(javascript) || arch(wasm32) || impl(mhs) if flag(native) && flag(production) js-sources: js/miso-native.prod.js @@ -182,7 +185,6 @@ library Miso.JSON.Parser Miso.JSON.Types Miso.Lens - Miso.Lens.Generic Miso.Mathml Miso.Mathml.Element Miso.Mathml.Property @@ -315,10 +317,23 @@ library Miso.DSL.TH.File other-modules: Data.JSString + elif impl(mhs) + hs-source-dirs: + ffi/mhs + other-modules: + GHC.Natural + GHC.OverloadedLabels + GHC.StaticPtr + Data.Text.Lazy.Encoding else hs-source-dirs: ffi/ghc + -- Uses type families and custom type errors, which MicroHs does not have + if !impl(mhs) + exposed-modules: + Miso.Lens.Generic + if flag(template-haskell) exposed-modules: Miso.Lens.TH diff --git a/sample-app/Makefile b/sample-app/Makefile index 5a23d25f9..429d5c436 100644 --- a/sample-app/Makefile +++ b/sample-app/Makefile @@ -59,13 +59,20 @@ build-js86: # MHS_TARGET is a section of MicroHs's targets.conf: browser (WebAssembly) # or browser_js (JavaScript only, -sWASM=0). MHS_TARGET=browser -MHS_FLAGS=-XCPP -DMHS -DMISO_TEXT -i../src -i../ffi/mhs +# -js embeds js/miso.js in the output (like js-sources in miso.cabal when built with mcabal) +MHS_FLAGS=-XCPP -DMHS -DMISO_TEXT -i../src -i../ffi/mhs -js ../js/miso.js mhs: mkdir -p public-mhs - cp ../js/miso.js public-mhs/ cp static-mhs/index.html public-mhs/ mhs $(MHS_FLAGS) -t$(MHS_TARGET) Main -opublic-mhs/app.js +# The same via mcabal (needs 'mcabal install' of miso first): js-sources are embedded automatically. +mhs-mcabal: + mcabal --options=-t$(MHS_TARGET) build + mkdir -p public-mhs + cp static-mhs/index.html public-mhs/ + cp dist-mcabal/bin/mhs/app public-mhs/app.js + serve-mhs: http-server public-mhs diff --git a/sample-app/static-mhs/index.html b/sample-app/static-mhs/index.html index b52d4d61e..67261b348 100644 --- a/sample-app/static-mhs/index.html +++ b/sample-app/static-mhs/index.html @@ -6,7 +6,6 @@ sample-app (MicroHs) - diff --git a/src/Miso/Lens.hs b/src/Miso/Lens.hs index 908ee07d1..5d271310b 100644 --- a/src/Miso/Lens.hs +++ b/src/Miso/Lens.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} diff --git a/ts/playwright-mhs.ts b/ts/playwright-mhs.ts index e3ae89476..a7478b48a 100644 --- a/ts/playwright-mhs.ts +++ b/ts/playwright-mhs.ts @@ -1,7 +1,7 @@ // Browser smoke test for the sample app built with MicroHs (see scripts/playwright-mhs.sh). // Loads the page served on port 8080, clicks the counter buttons, and prints // SUCCESS or ERROR (the same protocol as playwright.ts). -const { chromium } = require('playwright'); +import { chromium } from 'playwright'; (async () => { const browser = await chromium.launch({ headless: true }); From c069bfa7d52f19f262ff2c75223a9ca0a56a582b Mon Sep 17 00:00:00 2001 From: dmjio Date: Sun, 20 Sep 2026 10:46:11 -0500 Subject: [PATCH 03/34] nix: build the sample app with MicroHs, add playwright-mhs nix/mhs/default.nix packages the MicroHs toolchain (dmjio/MicroHs, branch rts-standalone, from nix/source.nix), the packages miso needs under mhs (ghc-compat, array-mhs, transformers, mtl, containers 0.8, an empty template-haskell), miso itself installed with mcabal, and the sample app built for the browser with miso.js embedded via js-sources. playwright-mhs serves that bundle and runs ts/playwright-mhs.ts, like playwright-wasm; it is added to the CI workflow. --- .github/workflows/main.yml | 3 + default.nix | 15 +++++ nix/mhs/default.nix | 134 +++++++++++++++++++++++++++++++++++++ nix/overlay.nix | 3 + nix/source.nix | 37 ++++++++++ 5 files changed, 192 insertions(+) create mode 100644 nix/mhs/default.nix diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index e9f667d7c..7f889bfde 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -103,6 +103,9 @@ jobs: - name: (WASM) Miso integration tests run: nix-build -A playwright-wasm && ./result/bin/playwright + - name: (MHS) Miso sample app built with MicroHs, browser smoke test + run: nix-build -A playwright-mhs && ./result/bin/playwright + - name: Nix garbage collection run: cabal clean && nix-collect-garbage -d diff --git a/default.nix b/default.nix index df224086f..b4954c71c 100644 --- a/default.nix +++ b/default.nix @@ -192,6 +192,21 @@ rec { exit "$exit_code" ''; + # The sample app built with MicroHs (mhs), see nix/mhs/default.nix, driven + # by the smoke test in ts/playwright-mhs.ts. + inherit (pkgs) microhs microhs-packages miso-mhs sample-app-mhs-bundle; + playwright-mhs = pkgs.writeScriptBin "playwright" '' + #!${pkgs.stdenv.shell} + export PLAYWRIGHT_BROWSERS_PATH=${pkgs.playwright-driver.browsers} + export PATH="${pkgs.lib.makeBinPath [ pkgs.http-server pkgs.bun ]}:$PATH" + bun install playwright@${pkgs.playwright-driver.version} + http-server ${pkgs.sample-app-mhs-bundle} & + bun run ts/playwright-mhs.ts + exit_code=$? + pkill http-server + exit "$exit_code" + ''; + # Same as playwright-wasm, but miso is built with the 'aeson' cabal flag # (Miso.JSON defined in terms of Data.Aeson). Nix-native now (see # miso-tests-aeson-wasm-bundle-ghc9141 above) -- unblocked by the nixpkgs diff --git a/nix/mhs/default.nix b/nix/mhs/default.nix new file mode 100644 index 000000000..e0179c189 --- /dev/null +++ b/nix/mhs/default.nix @@ -0,0 +1,134 @@ +# MicroHs (mhs) toolchain, the packages miso needs under mhs, and the sample +# app built with mhs for the browser (used by playwright-mhs in default.nix). +# +# Layout: the mhs installation (binaries, base package, runtime sources, +# targets.conf) lives in microhs/lib/mcabal like nixpkgs' microhs. Each +# further derivation copies that package database, installs more packages +# into the copy with mcabal, and points mhs at it with -a. +self: super: +let + src = import ../source.nix super; + version = "0.15.3.0"; + # Package database of a derivation, as seen by mhs/mcabal. + cabalDir = drv: "${drv}/lib/mcabal"; + mhsDir = drv: "${cabalDir drv}/mhs-${version}"; + # Start a writable copy of a package database in $out. + copyDB = drv: '' + mkdir -p $out/lib + cp -r ${cabalDir drv} $out/lib/mcabal + chmod -R u+w $out/lib/mcabal + export CABALDIR=$out/lib/mcabal + export HOME=$TMPDIR + ''; + # mcabal with the package database of $CABALDIR + mcabal = "mcabal -a$CABALDIR/mhs-${version}"; +in +rec { + microhs = super.stdenv.mkDerivation { + pname = "microhs"; + inherit version; + src = src.microhs; + # The compiler is built from the pre-generated C (generated/mhs.c), + # then 'make install' compiles it again with the installation paths, + # and installs cpphs, mcabal and the base package. + buildPhase = '' + runHook preBuild + make bin/mhs bin/cpphs bin/mcabal + runHook postBuild + ''; + installPhase = '' + runHook preInstall + export CABALDIR=$out/lib/mcabal + export HOME=$TMPDIR + make MCABAL=$out/lib/mcabal install + mkdir -p $out/bin + for b in mhs mcabal cpphs; do ln -s ../lib/mcabal/bin/$b $out/bin/$b; done + runHook postInstall + ''; + passthru = { isMhs = true; }; + }; + + # ghc-compat, array, transformers, mtl, containers (and an empty + # template-haskell, which containers depends on) installed for mhs. + microhs-packages = super.stdenv.mkDerivation { + pname = "microhs-packages"; + inherit version; + dontUnpack = true; + nativeBuildInputs = [ microhs ]; + installPhase = '' + runHook preInstall + ${copyDB microhs} + inst() { + rm -rf pkg; cp -r "$1" pkg; chmod -R u+w pkg + (cd "pkg$2" && ${mcabal} -q install) + } + inst ${src.mhs-ghc-compat} + inst ${src.mhs-array} + inst ${src.mhs-transformers} + # mtl 2.3.1: MicroHs cannot parse the poly-kinded instance head + rm -rf pkg; cp -r ${src.mhs-mtl} pkg; chmod -R u+w pkg + sed -i 's/^instance forall k (r :: k) (m :: (k -> Type)) \. MonadCont (ContT r m) where/instance MonadCont (ContT r m) where/' pkg/Control/Monad/Cont/Class.hs + (cd pkg && ${mcabal} -q install) + # containers depends on template-haskell (only for Lift instances, which are not compiled) + rm -rf pkg; mkdir pkg + cat > pkg/template-haskell.cabal < .lynx.bundle). `self` is the final # overlayed pkgs, so it already has rspeedy/bun. See nix/lib/mk-lynx-bundle.nix. mkLynxBundle = import ./lib/mk-lynx-bundle.nix self; diff --git a/nix/source.nix b/nix/source.nix index a257ebd3a..b76a36823 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -69,4 +69,41 @@ in rev = "b25d91bb51241d496adfb2b1f8f8dd593efe646b"; sha256 = "1wi3vpswik9wj8x16ik5v17sjkd537c482kiavh719kfaz4h7884"; }; + + # MicroHs (mhs) with the JSVal / JavaScript FFI, browser targets and + # js-sources support (dmjio/MicroHs, branch rts-standalone), plus the + # packages miso needs when built with mhs. See nix/mhs/default.nix. + microhs = fetchFromGitHub { + owner = "dmjio"; + repo = "MicroHs"; + rev = "22b26e0e4bf07db61d41e2e6eced0904392cc478"; + hash = "sha256-TvKx+ofbc1KwfPfaWbEAwEjTXekDNVQo96ZJ9O7fLRM="; + }; + mhs-ghc-compat = fetchFromGitHub { + owner = "augustss"; + repo = "ghc-compat"; + rev = "e04bd70e4040d52cd1d319387bda7514000b58a0"; + hash = "sha256-YRmgq3v/V3ewX9I1czFxPNfQ1r9c9YUV0MCMUPN/HpE="; + }; + mhs-array = fetchFromGitHub { + owner = "augustss"; + repo = "array-mhs"; + rev = "cbc2dbc31a84c7bcebef4a15b045e4ce21b27984"; + hash = "sha256-5qIch+MNsOMyP3pDRC4/mgGUX33y67eG0Bhtgq7sE+E="; + }; + # containers 0.8 has MicroHs support (__MHS__) + mhs-containers = fetchFromGitHub { + owner = "haskell"; + repo = "containers"; + rev = "0c3b9ee93af23f86fb8ad5ffe7729cb82fc4cd3a"; + hash = "sha256-I8QOxeTPw1sSfSiFaaLqDRZPLP1j7rvusZRDzxzZ1fI="; + }; + mhs-transformers = fetchzip { + url = "https://hackage.haskell.org/package/transformers-0.6.1.2/transformers-0.6.1.2.tar.gz"; + sha256 = "1hyqi74hamb9cry60r7i4l62ml2rbn2agrkmzav4bqznmfwz097w"; + }; + mhs-mtl = fetchzip { + url = "https://hackage.haskell.org/package/mtl-2.3.1/mtl-2.3.1.tar.gz"; + sha256 = "0mrh1n5i1d00rslrjwj8fvnfjpsjx6aswixa93bx6v94kxlkkakh"; + }; } From b637db2b920ee7554b74408ecebb6902b1f17ea1 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sun, 20 Sep 2026 11:49:21 -0500 Subject: [PATCH 04/34] Run the integration tests under MicroHs in playwright-mhs tests/app/Main.hs compiles with mhs: the Generic/Lens.Generic/Router/Static tests and derived JSON instances are guarded with __MHS__ (the Person JSON instances are written by hand there), GHC.Natural is replaced by Numeric.Natural, and miso-tests.cabal gets an impl(mhs) arm. nix/mhs/default.nix builds the tests as miso-tests-mhs-bundle and playwright-mhs now runs ts/playwright.ts against it with the echo server, like playwright-wasm. MicroHs is bumped to a revision whose runtime yields to the JavaScript event loop while Haskell threads wait for callbacks. --- .github/workflows/main.yml | 2 +- default.nix | 13 +++++--- nix/mhs/default.nix | 28 ++++++++++++++++ nix/overlay.nix | 4 +-- nix/source.nix | 6 ++-- tests/app/Main.hs | 68 ++++++++++++++++++++++++++++++++++---- tests/miso-tests.cabal | 3 ++ 7 files changed, 107 insertions(+), 17 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 7f889bfde..a1d536f39 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -103,7 +103,7 @@ jobs: - name: (WASM) Miso integration tests run: nix-build -A playwright-wasm && ./result/bin/playwright - - name: (MHS) Miso sample app built with MicroHs, browser smoke test + - name: (MHS) Miso integration tests built with MicroHs run: nix-build -A playwright-mhs && ./result/bin/playwright - name: Nix garbage collection diff --git a/default.nix b/default.nix index b4954c71c..1817ca4f0 100644 --- a/default.nix +++ b/default.nix @@ -192,18 +192,21 @@ rec { exit "$exit_code" ''; - # The sample app built with MicroHs (mhs), see nix/mhs/default.nix, driven - # by the smoke test in ts/playwright-mhs.ts. - inherit (pkgs) microhs microhs-packages miso-mhs sample-app-mhs-bundle; + # Same as playwright-wasm, but miso and the integration tests are built with + # MicroHs (mhs), see nix/mhs/default.nix. + inherit (pkgs) microhs microhs-packages miso-mhs sample-app-mhs-bundle miso-tests-mhs-bundle; playwright-mhs = pkgs.writeScriptBin "playwright" '' #!${pkgs.stdenv.shell} export PLAYWRIGHT_BROWSERS_PATH=${pkgs.playwright-driver.browsers} export PATH="${pkgs.lib.makeBinPath [ pkgs.http-server pkgs.bun ]}:$PATH" bun install playwright@${pkgs.playwright-driver.version} - http-server ${pkgs.sample-app-mhs-bundle} & - bun run ts/playwright-mhs.ts + http-server ${pkgs.miso-tests-mhs-bundle} & + bun run ts/echo-server.ts & + cd tests + bun run ../ts/playwright.ts exit_code=$? pkill http-server + pkill -f echo-server exit "$exit_code" ''; diff --git a/nix/mhs/default.nix b/nix/mhs/default.nix index e0179c189..4c650c9b6 100644 --- a/nix/mhs/default.nix +++ b/nix/mhs/default.nix @@ -131,4 +131,32 @@ rec { runHook postInstall ''; }; + + # The integration tests (tests/app/Main.hs) built with mhs for the browser, + # driven by ts/playwright.ts (see playwright-mhs in default.nix). + miso-tests-mhs-bundle = super.stdenv.mkDerivation { + pname = "miso-tests-mhs-bundle"; + version = "1.14.0.0"; + src = src.miso-tests; + nativeBuildInputs = [ microhs super.emscripten ]; + buildPhase = '' + runHook preBuild + export CABALDIR=$TMPDIR/mcabal + cp -r ${cabalDir miso-mhs} $CABALDIR + chmod -R u+w $CABALDIR + export HOME=$TMPDIR + export EM_CACHE=$TMPDIR/emcache + cp -r ${super.emscripten}/share/emscripten/cache $EM_CACHE + chmod -R u+w $EM_CACHE + ${mcabal} --options=-tbrowser build + runHook postBuild + ''; + installPhase = '' + runHook preInstall + mkdir -p $out + cp ${../../sample-app/static-mhs/index.html} $out/index.html + cp dist-mcabal/bin/mhs/component-tests $out/app.js + runHook postInstall + ''; + }; } diff --git a/nix/overlay.nix b/nix/overlay.nix index 72c4a2116..beecf6d48 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -14,8 +14,8 @@ in # JS tooling inherit (js) rspeedy; - # MicroHs (mhs) toolchain and the sample app built with it, see nix/mhs/default.nix - inherit (import ./mhs self super) microhs microhs-packages miso-mhs sample-app-mhs-bundle; + # MicroHs (mhs) toolchain, the sample app and the tests built with it, see nix/mhs/default.nix + inherit (import ./mhs self super) microhs microhs-packages miso-mhs sample-app-mhs-bundle miso-tests-mhs-bundle; # Reusable Lynx bundler (GHC-JS app -> .lynx.bundle). `self` is the final # overlayed pkgs, so it already has rspeedy/bun. See nix/lib/mk-lynx-bundle.nix. diff --git a/nix/source.nix b/nix/source.nix index b76a36823..36a705db7 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -14,7 +14,7 @@ let baseName = baseNameOf (toString name); excluded = [ ".git" ".github" ".gradle" ".stack-work" "coverage" - "dist" "dist-newstyle" "node_modules" "result" + "dist" "dist-newstyle" "dist-mcabal" "node_modules" "result" ] ++ excludedNames; in (!elem baseName excluded && ( @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "22b26e0e4bf07db61d41e2e6eced0904392cc478"; - hash = "sha256-TvKx+ofbc1KwfPfaWbEAwEjTXekDNVQo96ZJ9O7fLRM="; + rev = "08442f79f0e151c840f3863bd10fc52dd7788eca"; + hash = "sha256-57ZcThgryxvuXXOEf9SphDtHOiOw0CqwQeQu27DYwGo="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; diff --git a/tests/app/Main.hs b/tests/app/Main.hs index 45e3d6e1a..d06284231 100644 --- a/tests/app/Main.hs +++ b/tests/app/Main.hs @@ -11,7 +11,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StaticPointers #-} -#ifndef GHCJS_OLD +#if !defined(GHCJS_OLD) && !defined(__MHS__) {-# LANGUAGE QuasiQuotes #-} #endif ----------------------------------------------------------------------------- @@ -25,15 +25,21 @@ import Data.Map.Strict (Map) import qualified Data.IntMap.Strict as IM import Data.IntMap.Strict (IntMap) import Data.Char (toLower) +#ifdef __MHS__ +import Prelude hiding (setField, (!!)) +#else import Prelude hiding ((!!)) +#endif import GHC.Generics import Control.Monad import Data.Either import Data.IORef import Data.Text (Text) import GHC.Fingerprint (Fingerprint(..), fingerprint0) -import GHC.Natural (Natural) +import Numeric.Natural (Natural) +#ifndef __MHS__ import GHC.StaticPtr (StaticKey) +#endif import qualified Data.Text as T import Control.Monad.State ----------------------------------------------------------------------------- @@ -46,10 +52,12 @@ import qualified Miso.Data.Map as MDM import qualified Miso.Data.Set as MDS import qualified Miso.Data.Array as Array import qualified Miso.Date as D -#ifndef GHCJS_OLD +#if !defined(GHCJS_OLD) && !defined(__MHS__) import Miso.FFI.QQ (js) #endif +#ifndef __MHS__ import Miso.Lens.Generic +#endif import Miso.Lens import Miso.Test import Miso.Html @@ -154,11 +162,14 @@ testComponent = component (0 :: Int) update_ $ \_ -> button_ [ id_ "foo", onClic ----------------------------------------------------------------------------- data Action = AddOne deriving stock (Show, Eq, Generic) +#ifndef __MHS__ deriving anyclass (JSON.FromJSON, JSON.ToJSON) +#endif ----------------------------------------------------------------------------- -- | Two distinct components mounted statically at the same position by -- 'staticSwapRoot'; the differ must replace one with the other, not keep the -- first and run the second's @diffProps@ against it. +#ifndef __MHS__ staticProbeA, staticProbeB :: Component () () () Action staticProbeA = component () noop $ \_ -> div_ [ id_ "static-a" ] [ "A" ] staticProbeB = component () noop $ \_ -> div_ [ id_ "static-b" ] [ "B" ] @@ -170,12 +181,15 @@ staticSwapRoot = component False (\AddOne -> this %= not) $ \swapped -> then vcomp_ (static (mountStatic staticProbeB)) else vcomp_ (static (mountStatic staticProbeA)) ] +#endif ----------------------------------------------------------------------------- -- | Increments the app-global @context@ (an 'Int'); used to test that -- 'useContext' gates whether a 'vcontext' subtree observes the change. data ContextAction = BumpContext deriving stock (Show, Eq, Generic) +#ifndef __MHS__ deriving anyclass (JSON.FromJSON, JSON.ToJSON) +#endif ----------------------------------------------------------------------------- #ifdef WASM #ifndef INTERACTIVE @@ -183,23 +197,39 @@ foreign export javascript "hs_start" main :: IO () #endif #endif ----------------------------------------------------------------------------- +#ifndef __MHS__ data Route = Index | Home | Widget (Capture "thing" Int) (Path "foo") (Capture "other" MisoString) (QueryParam "bar" Int) (QueryParam "lol" Int) deriving stock (Generic, Show, Eq) deriving anyclass Router +#endif ----------------------------------------------------------------------------- data Person = Person { name :: MisoString, age :: Int } +#ifndef __MHS__ deriving stock Generic deriving anyclass (ToJSVal, ToObject) +#else +-- MicroHs has no Generic-based defaults +instance ToObject Person where + toObject (Person n a) = do + o <- create + setField o "name" =<< toJSVal n + setField o "age" =<< toJSVal a + pure o +instance ToJSVal Person where + toJSVal p = toJSVal =<< toObject p +#endif ---------------------------------------------------------------------------- -- Types for generic JSON encoding/decoding tests ---------------------------------------------------------------------------- -- Nullary sum data Color = Red | Green | Blue deriving stock (Generic, Show, Eq) +#ifndef __MHS__ deriving anyclass (JSON.ToJSON, JSON.FromJSON) +#endif ---------------------------------------------------------------------------- -- Single-constructor record (no tag) data Point = Point { px :: Int, py :: Int } @@ -215,12 +245,16 @@ instance JSON.FromJSON Point where -- Single-constructor newtype-like (unwrapped) data Wrapper = Wrapper Int deriving stock (Generic, Show, Eq) +#ifndef __MHS__ deriving anyclass (JSON.ToJSON, JSON.FromJSON) +#endif ---------------------------------------------------------------------------- -- Single-constructor with a list field (exercises parseProd gFieldCount == 1 fix) data WrapperList = WrapperList [MisoString] deriving stock (Generic, Show, Eq) +#ifndef __MHS__ deriving anyclass (JSON.ToJSON, JSON.FromJSON) +#endif ---------------------------------------------------------------------------- -- Multi-constructor sum with positional fields data Shape @@ -228,24 +262,32 @@ data Shape | Rectangle Double Double | Dot deriving stock (Generic, Show, Eq) +#ifndef __MHS__ deriving anyclass (JSON.ToJSON, JSON.FromJSON) +#endif ---------------------------------------------------------------------------- -- Multi-constructor sum with record fields data Animal = Cat { catName :: MisoString, lives :: Int } | Dog { dogName :: MisoString, tricks :: Int } deriving stock (Generic, Show, Eq) +#ifndef __MHS__ deriving anyclass (JSON.ToJSON, JSON.FromJSON) +#endif ---------------------------------------------------------------------------- -- Record with Maybe field data Profile = Profile { handle :: MisoString, bio :: Maybe MisoString } deriving stock (Generic, Show, Eq) +#ifndef __MHS__ deriving anyclass (JSON.ToJSON, JSON.FromJSON) +#endif ---------------------------------------------------------------------------- -- Record with camelCase fields for fieldLabelModifier tests data CamelRecord = CamelRecord { firstName :: MisoString, lastName :: MisoString } deriving stock (Generic, Show, Eq) +#ifndef __MHS__ deriving anyclass (JSON.ToJSON, JSON.FromJSON) +#endif ---------------------------------------------------------------------------- -- Sum type with a single-field constructor whose field type is a list -- (exercises the parseTaggedCon gFieldCount == 1 fix) @@ -253,12 +295,16 @@ data NestedList = NestedList [MisoString] | EmptyNested deriving stock (Generic, Show, Eq) +#ifndef __MHS__ deriving anyclass (JSON.ToJSON, JSON.FromJSON) +#endif ---------------------------------------------------------------------------- -- Zero-field single constructor (exercises parseProd 0-field guard) data Nullary = Nullary deriving stock (Generic, Show, Eq) +#ifndef __MHS__ deriving anyclass (JSON.ToJSON, JSON.FromJSON) +#endif ---------------------------------------------------------------------------- -- JSON helpers that work whether miso is built with its own JSON -- representation or with the aeson flag (where Value is aeson's type: @@ -284,7 +330,7 @@ isError _ = False getAge :: Person -> IO Int getAge = inline "return age;" ---------------------------------------------------------------------------- -#ifndef GHCJS_OLD +#if !defined(GHCJS_OLD) && !defined(__MHS__) factorial :: Int -> IO Int factorial n = [js| let x = 1; @@ -303,12 +349,14 @@ square n = [js| main :: IO () main = withJS $ do runTests $ beforeEach clearBody $ afterEach clearComponentState $ do +#ifndef __MHS__ describe "Miso.Lens.Generic tests" $ do it "Should update field generically" $ do let john = Person "john" 30 (john ^. field @"name") `shouldBe` "john" let bob = john & field @"name" .~ "bob" (bob ^. field @"name") `shouldBe` "bob" +#endif describe "Miso.Storage tests" $ do it "Should get and set in localStorage" $ do (`shouldBe` 0) =<< liftIO localStorageLength @@ -689,6 +737,7 @@ main = withJS $ do decodePure "{\"a\":true,\"b\":1.1}" `shouldBe` Right (JSON.object [("a",JSON.Bool True),("b",JSON.Number 1.1)]) +#ifndef __MHS__ describe "Miso.JSON generic encoding tests" $ do -- Nullary sum constructors → bare String (allNullaryToStringTag = True) it "encodes nullary sum constructors as bare strings" $ do @@ -820,7 +869,7 @@ main = withJS $ do it "round-trips nullary sibling of single-field list constructor" $ do (JSON.fromJSON (JSON.toJSON EmptyNested) :: JSON.Result NestedList) `shouldBe` JSON.Success EmptyNested -#ifndef GHCJS_OLD +#if !defined(GHCJS_OLD) && !defined(__MHS__) -- #3: omitNothingFields = True decode — missing key decodes as Nothing it "decodes missing key as Nothing when omitNothingFields was used" $ do let opts = JSON.defaultOptions { JSON.omitNothingFields = True } @@ -896,6 +945,7 @@ main = withJS $ do JSON.encodePure (JSON.object [("ke\"y", JSON.Bool True)]) `shouldBe` "{\"ke\\\"y\":true}" +#endif -- toJSONList: String (i.e. [Char]) serializes as a JSON string while -- other lists serialize as JSON arrays. This replaces the old -- OVERLAPPING/OVERLAPPABLE ToJSON String / ToJSON [a] instances. @@ -1001,7 +1051,7 @@ main = withJS $ do (`shouldBe` False) =<< liftIO (MDS.isDisjoint k k) (`shouldBe` True) =<< liftIO (MDS.isDisjoint x y) -#ifndef GHCJS_OLD +#if !defined(GHCJS_OLD) && !defined(__MHS__) describe "inline JS QQ tests" $ do it "should use inline JS to calc factorial" $ (`shouldBe` 120) =<< liftIO (factorial 5) @@ -1140,6 +1190,7 @@ main = withJS $ do describe "Inline JS tests" $ do it "Should use inline js" $ do (`shouldBe` 42) =<< liftIO (getAge (Person "larry" 42)) +#ifndef __MHS__ describe "Router tests" $ do it "should call fromRoute on Index" $ do fromRoute Index `shouldBe` [ IndexToken ] @@ -1209,6 +1260,7 @@ main = withJS $ do lexTokens "/foo?bar#cool" `shouldBe` Right [CaptureOrPathToken "foo", QueryParamToken "bar" Nothing, FragmentToken "cool"] +#endif describe "MisoString tests" $ do it "Should pack" $ do S.unpack (S.pack "foo") `shouldBe` @@ -1800,6 +1852,7 @@ main = withJS $ do liftIO (unmountComponent rootState) mountedComponents >>= (`shouldBe` 0) +#ifndef __MHS__ it "On after OnStatic on the same node must not inherit a stale staticKey" $ do -- Regression for: an 'OnStatic' handler stashes 'pendingStaticKey' / -- 'pendingMainThread' on the shared vnode object so 'onWithOptions' @@ -1827,7 +1880,9 @@ main = withJS $ do clickStaticKey <- liftIO (clickHandler ! "staticKey") clickStaticKeyUndefined <- liftIO (isUndefined clickStaticKey) clickStaticKeyUndefined `shouldBe` False +#endif +#ifndef __MHS__ describe "Static mount identity tests" $ do it "swapping two static mounts at one position replaces the child" $ do liftIO $ startApp mempty staticSwapRoot @@ -1848,6 +1903,7 @@ main = withJS $ do ("document.getElementById('static-a') !== null" :: MisoString) hasA `shouldBe` False +#endif describe "VContext tests" $ do let contextProbe :: Component Int () () Action contextProbe = component () noop $ \_ -> diff --git a/tests/miso-tests.cabal b/tests/miso-tests.cabal index 92a3832a0..aff05edd5 100644 --- a/tests/miso-tests.cabal +++ b/tests/miso-tests.cabal @@ -35,6 +35,9 @@ common cpp elif arch(wasm32) cpp-options: -DWASM + elif impl(mhs) + cpp-options: + -DMHS -DMISO_TEXT else cpp-options: -DVANILLA From 6fcb7079bb6ba3f652d0606fdddfc705d9fc7947 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sun, 20 Sep 2026 12:35:08 -0500 Subject: [PATCH 05/34] Bump MicroHs: threads keep running after an event callback Fixes the one-event render lag of the sample app under mhs: the runtime now runs miso's scheduler thread right after the event handler that woke it, and resumes threadDelay via a JavaScript timer. --- nix/source.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/nix/source.nix b/nix/source.nix index 36a705db7..36f37b943 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "08442f79f0e151c840f3863bd10fc52dd7788eca"; - hash = "sha256-57ZcThgryxvuXXOEf9SphDtHOiOw0CqwQeQu27DYwGo="; + rev = "05538183bb21d0799c3d132048ec21be700eb936"; + hash = "sha256-OiIxzZDZGcQnRQyVOOCXgUjc3gLZ9i8xnV1Ndjp4lH4="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; From 6de4903297a890cabb57b283e05e1e3525ffceb3 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sun, 20 Sep 2026 15:17:06 -0500 Subject: [PATCH 06/34] createSub: keep the Sub thread's delay below 2^31 microseconds Int is 32 bits on wasm32. The old threadDelay (secs 10000) computed 10^10, which MicroHs rejects with an Overflow exception (GHC wraps it silently), killing the Sub thread and releasing its resource right after acquiring it, so e.g. windowSub listeners were removed immediately. --- src/Miso/Subscription/Util.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Miso/Subscription/Util.hs b/src/Miso/Subscription/Util.hs index 2501c414e..69c2dc0c6 100644 --- a/src/Miso/Subscription/Util.hs +++ b/src/Miso/Subscription/Util.hs @@ -47,7 +47,7 @@ -- @'createSub' acquire release sink@ runs: -- -- @ --- 'Control.Exception.bracket' acquire release (\\_ -> forever (threadDelay 10000_000_000)) +-- 'Control.Exception.bracket' acquire release (\\_ -> forever (threadDelay 1000_000_000)) -- @ -- -- The @forever@ loop keeps the subscription thread alive by sleeping in @@ -82,8 +82,12 @@ createSub -- ^ Release resource -> Sub model action createSub acquire release = \_ _ -> - bracket acquire release (\_ -> forever (threadDelay (secs 10000))) + bracket acquire release (\_ -> forever (threadDelay (secs 1000))) where + -- 'Int' is 32 bits on wasm32 (GHC and MicroHs), so the delay must stay + -- below 2^31 microseconds (about 2147 seconds); MicroHs throws + -- 'Overflow' on a larger product, which would kill the 'Sub' thread and + -- release the resource. secs :: Int -> Int secs = (*1000000) ---------------------------------------------------------------------------- From 6746e3db2fac5ac890f2296ad6f1bdbe8013709d Mon Sep 17 00:00:00 2001 From: dmjio Date: Sun, 20 Sep 2026 16:03:55 -0500 Subject: [PATCH 07/34] flake: add the mhs dev shell (nix develop .#mhs) mhs and mcabal from the pinned MicroHs, emscripten for the browser target, and node/bun/http-server. The shell hook copies the package database of miso-mhs (base, ghc-compat, containers, mtl, miso, ...) to ./.mcabal, since the store copy is read only and mcabal writes to it, and gives emcc a writable cache in ./.emcache. The mhs and mcabal on PATH are wrappers that add -a for that database unless a package path is given. make -C sample-app mhs-mcabal # against the installed miso package make -C sample-app mhs # miso from ../src Both directories are ignored by git and by the nix source filter. --- .gitignore | 5 +++++ flake.nix | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++ nix/source.nix | 2 +- 3 files changed, 60 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index c194098ce..97671b789 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,11 @@ dist # nix result* +# MicroHs shell (nix develop .#mhs) +.mcabal/ +.emcache/ +dist-mcabal/ + # emacs *~ diff --git a/flake.nix b/flake.nix index a59e8d9a3..6ff772d6f 100644 --- a/flake.nix +++ b/flake.nix @@ -171,6 +171,60 @@ ''; }; + # MicroHs shell: mhs and mcabal (with a writable package database + # that already contains miso, see nix/mhs/default.nix), emscripten + # for the browser target, and node/bun/http-server to run the result. + # + # nix develop .#mhs + # make -C sample-app mhs-mcabal # the installed miso package + # make -C sample-app mhs # miso from ../src (when hacking on miso) + # make -C sample-app serve-mhs + mhs = + let + mhsVersion = pkgs.microhs.version; + # mhs/mcabal look for packages in the (read-only) store copy of the + # database, so add the writable one from the shell hook, unless a + # package path was given explicitly or this is e.g. --version + # (which mhs only accepts on its own). + withPkgPath = exe: pkgs.writeShellScriptBin exe '' + if [ $# -eq 1 ] && [ "''${1#--}" != "$1" ]; then + exec ${pkgs.microhs}/bin/${exe} "$@" + fi + case " $* " in + *" -a"*) exec ${pkgs.microhs}/bin/${exe} "$@" ;; + *) exec ${pkgs.microhs}/bin/${exe} -a"$CABALDIR/mhs-${mhsVersion}" "$@" ;; + esac + ''; + in + pkgs.mkShell { + name = "The miso ${system} MicroHs shell"; + packages = with pkgs; [ + (withPkgPath "mhs") + (withPkgPath "mcabal") + microhs + emscripten + gnumake + bun + nodejs + http-server + ]; + shellHook = '' + export CABALDIR=$PWD/.mcabal + if [ ! -d "$CABALDIR" ]; then + echo "Copying the MicroHs package database (with miso) to $CABALDIR" + cp -r ${pkgs.miso-mhs}/lib/mcabal "$CABALDIR" + chmod -R u+w "$CABALDIR" + fi + # emcc needs a writable cache + export EM_CACHE=$PWD/.emcache + if [ ! -d "$EM_CACHE" ]; then + cp -r ${pkgs.emscripten}/share/emscripten/cache "$EM_CACHE" + chmod -R u+w "$EM_CACHE" + fi + echo "MicroHs ${mhsVersion} shell: packages in $CABALDIR (rm -rf it to reset)" + ''; + }; + # WASM shell wasm = pkgs.mkShell { diff --git a/nix/source.nix b/nix/source.nix index 36f37b943..e2783918c 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -14,7 +14,7 @@ let baseName = baseNameOf (toString name); excluded = [ ".git" ".github" ".gradle" ".stack-work" "coverage" - "dist" "dist-newstyle" "dist-mcabal" "node_modules" "result" + "dist" "dist-newstyle" "dist-mcabal" ".mcabal" ".emcache" "node_modules" "result" ] ++ excludedNames; in (!elem baseName excluded && ( From d4b2b4d0a144b49124e0fabc34c8073646721386 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sun, 20 Sep 2026 16:42:48 -0500 Subject: [PATCH 08/34] Bump MicroHs: browser-sized heap and GC pressure from JSVal handles The browser targets now use a 4M cell heap (about 60MB instead of 680MB) and the runtime forces a GC after 100000 new JSVal handles, so the JavaScript-side handle table stays bounded in long-running apps. --- nix/source.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/nix/source.nix b/nix/source.nix index e2783918c..90a7adaea 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "05538183bb21d0799c3d132048ec21be700eb936"; - hash = "sha256-OiIxzZDZGcQnRQyVOOCXgUjc3gLZ9i8xnV1Ndjp4lH4="; + rev = "2a16a58db5b2ea66ca7bbb29aa097201c376803f"; + hash = "sha256-25yW0amejQEVjv1Oe6zBND9FbTpTfbpEAYtRiZxvX2A="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; From d9ed097da6ffa3126ad514102524423ffd35ef67 Mon Sep 17 00:00:00 2001 From: dmjio Date: Mon, 21 Sep 2026 14:10:04 -0500 Subject: [PATCH 09/34] Remove the sample-app smoke test for mhs playwright-mhs runs the integration test suite now; the smoke test in ts/playwright-mhs.ts and its script are no longer used. --- scripts/playwright-mhs.sh | 18 ------------------ ts/playwright-mhs.ts | 31 ------------------------------- 2 files changed, 49 deletions(-) delete mode 100755 scripts/playwright-mhs.sh delete mode 100644 ts/playwright-mhs.ts diff --git a/scripts/playwright-mhs.sh b/scripts/playwright-mhs.sh deleted file mode 100755 index 950aab41d..000000000 --- a/scripts/playwright-mhs.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/bin/env bash -# Build the sample app with MicroHs (mhs, emscripten target) and run the -# browser smoke test in ts/playwright-mhs.ts. -# -# Needs on the PATH: mhs (with the emscripten target configured), emcc, node, -# http-server; and the playwright npm package (bun install / npm install) with -# PLAYWRIGHT_BROWSERS_PATH set (e.g. to nixpkgs' playwright-driver.browsers). -# -# Usage: scripts/playwright-mhs.sh [browser|browser_js] (default: browser) -set -euo pipefail -cd "$(dirname "$0")/.." -target="${1:-browser}" -make -C sample-app mhs MHS_TARGET="$target" -http-server sample-app/public-mhs -p 8080 -s & -server=$! -trap 'kill $server 2>/dev/null' EXIT -sleep 1 -NODE_PATH="$PWD/node_modules" node ts/playwright-mhs.ts diff --git a/ts/playwright-mhs.ts b/ts/playwright-mhs.ts deleted file mode 100644 index a7478b48a..000000000 --- a/ts/playwright-mhs.ts +++ /dev/null @@ -1,31 +0,0 @@ -// Browser smoke test for the sample app built with MicroHs (see scripts/playwright-mhs.sh). -// Loads the page served on port 8080, clicks the counter buttons, and prints -// SUCCESS or ERROR (the same protocol as playwright.ts). -import { chromium } from 'playwright'; - -(async () => { - const browser = await chromium.launch({ headless: true }); - const page = await browser.newPage(); - page.on('console', (msg) => console.log('[console:' + msg.type() + '] ' + msg.text())); - page.on('pageerror', (err) => console.log('[pageerror] ' + err.message)); - await page.goto('http://127.0.0.1:8080'); - try { - await page.waitForSelector('button', { timeout: 20000 }); - const text = async () => (await page.locator('body').innerText()).replace(/\s+/g, ''); - const before = await text(); - await page.getByText('+', { exact: true }).click(); - await page.getByText('+', { exact: true }).click(); - await page.getByText('-', { exact: true }).click(); - await page.waitForTimeout(300); - const after = await text(); - console.log(`before: ${before}, after: ${after}`); - const ok = before.includes('+0-') && after.includes('+1-'); - console.log(ok ? 'SUCCESS' : 'ERROR'); - await browser.close(); - process.exit(ok ? 0 : 1); - } catch (e) { - console.log('ERROR ' + e.message); - await browser.close(); - process.exit(1); - } -})(); From f98cfe7838e60a4762d85025d6776e44e73a85f0 Mon Sep 17 00:00:00 2001 From: dmjio Date: Mon, 21 Sep 2026 15:51:50 -0500 Subject: [PATCH 10/34] MicroHs: JSString as MisoString Data.JSString (the wasm backend's JSString implementation, now in ffi/jsstring so the wasm and mhs backends share it) compiles with MicroHs as is, apart from the Text conversions, which under __MHS__ come from MicroHs's GHC.Wasm.Prim. The impl(mhs) arm therefore drops -DMISO_TEXT: MisoString is JSString on MicroHs like on the other JavaScript backends, and strings are no longer re-marshalled on every render. The mhs FFI module gets the JSString versions of parseInt/parseDouble/... under #else of MISO_TEXT, as the wasm one has. Measured on miso-snake: FFI calls per tick 3466 -> 2185, new JSVal handles per tick 2337 -> 857, evaluator share of wall time halved. The 280 integration tests pass. --- ffi/{wasm => jsstring}/Data/JSString.hs | 8 +++++++ ffi/mhs/Miso/DSL/FFI.hs | 31 ++++++++++++++++++++++++- miso.cabal | 5 +++- sample-app/Makefile | 2 +- tests/miso-tests.cabal | 2 +- 5 files changed, 44 insertions(+), 4 deletions(-) rename ffi/{wasm => jsstring}/Data/JSString.hs (99%) diff --git a/ffi/wasm/Data/JSString.hs b/ffi/jsstring/Data/JSString.hs similarity index 99% rename from ffi/wasm/Data/JSString.hs rename to ffi/jsstring/Data/JSString.hs index 79ee8f186..6b60b7155 100644 --- a/ffi/wasm/Data/JSString.hs +++ b/ffi/jsstring/Data/JSString.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultilineStrings #-} {-# LANGUAGE UnboxedTuples #-} @@ -134,10 +135,15 @@ module Data.JSString , toString_Int ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +-- MicroHs: textFromJSString / textToJSString come from GHC.Wasm.Prim +import Data.Text (Text) +#else import Data.Array.Byte (ByteArray(..)) import Data.Text.Internal hiding (pack, empty, append) import GHC.Exts import GHC.IO +#endif import GHC.Wasm.Prim import qualified Data.List as List import qualified Data.Text as T @@ -737,6 +743,7 @@ zipWith f l r = f l' r' `cons` zipWith f ls rs _ -> mempty ----------------------------------------------------------------------------- +#ifndef __MHS__ newtype JSUint8Array = JSUint8Array JSVal ----------------------------------------------------------------------------- foreign import javascript unsafe "(new TextEncoder()).encode($1)" @@ -768,6 +775,7 @@ textToJSString (Text (ByteArray ba#) (I# off#) (I# len#)) = unsafeDupablePerform IO $ \s0 -> case newPinnedByteArray# len# s0 of (# s1, mba# #) -> case copyByteArray# ba# off# mba# 0# len# s1 of s2 -> keepAlive# mba# s2 $ unIO $ js_to_str (Ptr (mutableByteArrayContents# mba#)) $ I# len# +#endif ----------------------------------------------------------------------------- foreign import javascript unsafe """ diff --git a/ffi/mhs/Miso/DSL/FFI.hs b/ffi/mhs/Miso/DSL/FFI.hs index b39844dcc..be0cd8074 100644 --- a/ffi/mhs/Miso/DSL/FFI.hs +++ b/ffi/mhs/Miso/DSL/FFI.hs @@ -17,7 +17,8 @@ -- -- This mirrors the WASM FFI layer (ffi/wasm), using the 'GHC.Wasm.Prim' -- module of MicroHs, which provides 'JSVal', 'JSString', 'freeJSVal' and --- the callback functions. 'MisoString' is 'Text' on this backend +-- the callback functions. 'MisoString' is 'JSString' on this backend (or +-- 'Text' with MISO_TEXT) -- (i.e., MISO_TEXT is always defined). ----------------------------------------------------------------------------- module Miso.DSL.FFI @@ -91,10 +92,12 @@ module Miso.DSL.FFI , parseDouble , parseWord , parseFloat +#ifdef MISO_TEXT , toString_Int , toString_Double , toString_Float , toString_Word +#endif , textFromJSString , textToJSString , JSException @@ -357,6 +360,7 @@ fromJSValUnchecked_Maybe jsval = do -- | Parses like JS's @parseInt@: leading\/trailing whitespace and -- trailing garbage are ignored, a leading @+\/-@ is allowed, and a -- @0x@\/@0X@ prefix is read as hexadecimal. +#ifdef MISO_TEXT parseInt :: Text -> Maybe Int parseInt input = applySign <$> digits unsigned where @@ -408,4 +412,29 @@ toString_Float = T.pack . show ----------------------------------------------------------------------------- toString_Word :: Word -> Text toString_Word = T.pack . show +#else +foreign import javascript unsafe "return parseInt($1);" + parseInt_Unchecked :: JSString -> Double +----------------------------------------------------------------------------- +parseInt :: JSString -> Maybe Int +parseInt string = + case parseInt_Unchecked string of + double | isNaN double -> Nothing + | otherwise -> Just (round double) +----------------------------------------------------------------------------- +parseWord :: JSString -> Maybe Word +parseWord string = fromIntegral <$> parseInt string +----------------------------------------------------------------------------- +foreign import javascript unsafe "return parseFloat($1);" + parseDouble_Unchecked :: JSString -> Double +----------------------------------------------------------------------------- +parseDouble :: JSString -> Maybe Double +parseDouble string = + case parseDouble_Unchecked string of + double | isNaN double -> Nothing + | otherwise -> Just double +----------------------------------------------------------------------------- +parseFloat :: JSString -> Maybe Float +parseFloat string = realToFrac <$> parseDouble string +#endif ----------------------------------------------------------------------------- diff --git a/miso.cabal b/miso.cabal index 0fe880eb3..b6865aa6b 100644 --- a/miso.cabal +++ b/miso.cabal @@ -43,7 +43,7 @@ common cpp -DWASM elif impl(mhs) cpp-options: - -DMHS -DMISO_TEXT + -DMHS else cpp-options: -DVANILLA @@ -309,6 +309,7 @@ library elif arch(wasm32) hs-source-dirs: ffi/wasm + ffi/jsstring build-depends: ghc-experimental < 9.1500, template-haskell >= 2.21 && < 2.25 @@ -320,7 +321,9 @@ library elif impl(mhs) hs-source-dirs: ffi/mhs + ffi/jsstring other-modules: + Data.JSString GHC.Natural GHC.OverloadedLabels GHC.StaticPtr diff --git a/sample-app/Makefile b/sample-app/Makefile index 429d5c436..190298a34 100644 --- a/sample-app/Makefile +++ b/sample-app/Makefile @@ -60,7 +60,7 @@ build-js86: # or browser_js (JavaScript only, -sWASM=0). MHS_TARGET=browser # -js embeds js/miso.js in the output (like js-sources in miso.cabal when built with mcabal) -MHS_FLAGS=-XCPP -DMHS -DMISO_TEXT -i../src -i../ffi/mhs -js ../js/miso.js +MHS_FLAGS=-XCPP -DMHS -i../src -i../ffi/mhs -i../ffi/jsstring -js ../js/miso.js mhs: mkdir -p public-mhs diff --git a/tests/miso-tests.cabal b/tests/miso-tests.cabal index aff05edd5..b359b24dd 100644 --- a/tests/miso-tests.cabal +++ b/tests/miso-tests.cabal @@ -37,7 +37,7 @@ common cpp -DWASM elif impl(mhs) cpp-options: - -DMHS -DMISO_TEXT + -DMHS else cpp-options: -DVANILLA From 5a059c74eb8d43721dbe6a5c0cb5f015c6dc81c4 Mon Sep 17 00:00:00 2001 From: dmjio Date: Mon, 21 Sep 2026 16:00:33 -0500 Subject: [PATCH 11/34] Bump MicroHs to the jsstring branch (no JSString instances in Prim, browser target -Oz with wasm longjmp) --- nix/source.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/nix/source.nix b/nix/source.nix index 90a7adaea..aae8e1fb6 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "2a16a58db5b2ea66ca7bbb29aa097201c376803f"; - hash = "sha256-25yW0amejQEVjv1Oe6zBND9FbTpTfbpEAYtRiZxvX2A="; + rev = "4f377101aaa0c3fff413297561d27987c45fd82e"; + hash = "sha256-3MzZ3AWyeW5EtwFIMn8uCMq14A5QUg4ySnhXffu/fjw="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; From d0fee4b1c611572b692d1da858573450d405dad6 Mon Sep 17 00:00:00 2001 From: dmjio Date: Mon, 21 Sep 2026 18:45:03 -0500 Subject: [PATCH 12/34] Add Makefile.mhs: build with MicroHs on Ubuntu without nix `nix develop .#mhs` is the only documented way to get a MicroHs toolchain with miso in its package database. Makefile.mhs reaches the same place from apt and git: it installs mhs, mcabal and cpphs into ./.mcabal, adds the packages miso needs under mhs, installs miso itself, and builds the sample app. make -f Makefile.mhs apt # once, needs sudo make -f Makefile.mhs # -> sample-app/public-mhs make -f Makefile.mhs serve The end state is the database the mhs dev shell sets up, so the existing sample-app targets (mhs-mcabal, mhs, serve-mhs) work unchanged after it. Each step is guarded by a stamp under .mhs-bootstrap/stamp, so a rerun only redoes what was removed. Revisions are pinned to the same commits as nix/source.nix and have to be changed in both. Two of them are not interchangeable with the obvious alternative: MicroHs must be dmjio/MicroHs on rts-standalone (upstream has no JSVal FFI or browser targets), and mtl 2.3.1 needs its poly-kinded MonadCont instance head rewritten before mhs can parse it -- that patch is checked after it is applied so a version bump fails there instead of much later. emscripten is required either way: the browser targets compile with emcc. The emsdk step is skipped when emcc is already on PATH. --- .gitignore | 3 + Makefile.mhs | 192 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 195 insertions(+) create mode 100644 Makefile.mhs diff --git a/.gitignore b/.gitignore index 97671b789..cbd1fc7f4 100644 --- a/.gitignore +++ b/.gitignore @@ -47,3 +47,6 @@ haddocks/ sample-app-native/android/app/src/main/assets/main.lynx.bundle sample-app-native/android/app/src/main/assets/main.lynx.bundle.sha256 + +# MicroHs bootstrap (make -f Makefile.mhs) +.mhs-bootstrap/ diff --git a/Makefile.mhs b/Makefile.mhs new file mode 100644 index 000000000..be2dd906d --- /dev/null +++ b/Makefile.mhs @@ -0,0 +1,192 @@ +##################################################################### +# Build miso and the sample app with MicroHs (mhs), without nix. +# +# This is the nix-free equivalent of `nix develop .#mhs`: it ends with +# the same package database in ./.mcabal (mhs, mcabal, and miso), so the +# sample-app targets documented in flake.nix work unchanged afterwards. +# +# make -f Makefile.mhs apt # Ubuntu prerequisites (needs sudo, run once) +# make -f Makefile.mhs # everything -> sample-app/public-mhs +# make -f Makefile.mhs serve # http://localhost:8080 +# +# Steps run in this order, each guarded by a stamp in .mhs-bootstrap/stamp: +# +# emsdk emscripten, for the -tbrowser target's emcc +# microhs mhs, mcabal and cpphs, installed into ./.mcabal +# packages the packages miso needs under mhs +# miso this checkout, installed as an mhs package +# app sample-app, via sample-app/Makefile's mhs-mcabal target +# +# To redo one step, delete its stamp (or `make -f Makefile.mhs clean`). +# Revisions are kept in step with nix/source.nix -- change them in both. +##################################################################### + +MHS_VERSION := 0.15.3.0 + +# MicroHs with the JSVal/JavaScript FFI and browser targets: dmjio/MicroHs, +# branch rts-standalone. Upstream augustss/MicroHs will not work. +MICROHS_URL := https://github.com/dmjio/MicroHs +MICROHS_REV := 2a16a58db5b2ea66ca7bbb29aa097201c376803f + +GHC_COMPAT_URL := https://github.com/augustss/ghc-compat +GHC_COMPAT_REV := e04bd70e4040d52cd1d319387bda7514000b58a0 +ARRAY_URL := https://github.com/augustss/array-mhs +ARRAY_REV := cbc2dbc31a84c7bcebef4a15b045e4ce21b27984 +# containers 0.8 has MicroHs support (__MHS__) +CONTAINERS_URL := https://github.com/haskell/containers +CONTAINERS_REV := 0c3b9ee93af23f86fb8ad5ffe7729cb82fc4cd3a +TRANSFORMERS_VERSION := 0.6.1.2 +MTL_VERSION := 2.3.1 + +# miso's cabal flags under mhs (see nix/mhs/default.nix). +MISO_FLAGS := -template-haskell -aeson -native -production -ssr -benchmark text + +# The section of MicroHs's targets.conf to compile for: browser +# (WebAssembly) or browser_js (JavaScript only, -sWASM=0). +MHS_TARGET ?= browser + +SERVE_PORT ?= 8080 + +##################################################################### + +WORK := $(CURDIR)/.mhs-bootstrap +SRC := $(WORK)/src +STAMP := $(WORK)/stamp +EMSDK_DIR := $(WORK)/emsdk + +# mcabal installs into $CABALDIR; mhs is built below with its data directory +# baked in to match, so neither needs -a. +export CABALDIR := $(CURDIR)/.mcabal +export PATH := $(CABALDIR)/bin:$(PATH) + +# emsdk_env.sh puts emcc on PATH. Skipped when the system already has one. +EMSDK_ENV = if [ -f $(EMSDK_DIR)/emsdk_env.sh ]; then . $(EMSDK_DIR)/emsdk_env.sh >/dev/null; fi + +# Check out $(2) at exactly revision $(3) into $(SRC)/$(1), without +# downloading the rest of the history. +define git-at-rev + @mkdir -p $(SRC) + @test -d $(SRC)/$(1)/.git || { \ + git init -q $(SRC)/$(1); \ + git -C $(SRC)/$(1) remote add origin $(2); \ + } + git -C $(SRC)/$(1) fetch -q --depth 1 origin $(3) + git -C $(SRC)/$(1) checkout -q --detach FETCH_HEAD +endef + +# Unpack hackage package $(1)-$(2) into $(SRC)/$(1)-$(2). +define hackage-at-version + @mkdir -p $(SRC) + @test -d $(SRC)/$(1)-$(2) || curl -sSfL \ + https://hackage.haskell.org/package/$(1)-$(2)/$(1)-$(2).tar.gz | tar xz -C $(SRC) +endef + +.PHONY: all apt emsdk microhs packages miso app serve clean +.PHONY: package-ghc-compat package-array package-transformers +.PHONY: package-mtl package-template-haskell package-containers + +all: app + +# Run once. Kept out of `all` so the build never surprises you with sudo. +apt: + sudo apt-get update + sudo apt-get install -y build-essential git curl ca-certificates python3 xz-utils + +##################################################################### +# emscripten + +emsdk: $(STAMP)/emsdk +$(STAMP)/emsdk: + @mkdir -p $(STAMP) + @if command -v emcc >/dev/null 2>&1; then \ + echo "emcc already on PATH, not installing emsdk"; \ + else \ + test -d $(EMSDK_DIR) || git clone -q --depth 1 \ + https://github.com/emscripten-core/emsdk $(EMSDK_DIR); \ + $(EMSDK_DIR)/emsdk install latest; \ + $(EMSDK_DIR)/emsdk activate latest; \ + fi + @touch $@ + +##################################################################### +# MicroHs: mhs, mcabal, cpphs and the base package, installed into .mcabal + +microhs: $(STAMP)/microhs +$(STAMP)/microhs: + @mkdir -p $(STAMP) + $(call git-at-rev,MicroHs,$(MICROHS_URL),$(MICROHS_REV)) + $(MAKE) -C $(SRC)/MicroHs bin/mhs bin/cpphs bin/mcabal + # Paths_MicroHs.hs bakes in the data directory and is not regenerated + # on its own, so drop it in case an earlier build used another CABALDIR. + rm -f $(SRC)/MicroHs/dist-mcabal/Paths_MicroHs.hs + $(MAKE) -C $(SRC)/MicroHs MCABAL=$(CABALDIR) install + @touch $@ + +##################################################################### +# The packages miso needs under mhs + +packages: $(STAMP)/packages +$(STAMP)/packages: package-ghc-compat package-array package-transformers \ + package-mtl package-template-haskell package-containers + @mkdir -p $(STAMP) + @touch $@ + +package-ghc-compat: $(STAMP)/microhs + $(call git-at-rev,ghc-compat,$(GHC_COMPAT_URL),$(GHC_COMPAT_REV)) + cd $(SRC)/ghc-compat && mcabal -q install + +package-array: $(STAMP)/microhs + $(call git-at-rev,array-mhs,$(ARRAY_URL),$(ARRAY_REV)) + cd $(SRC)/array-mhs && mcabal -q install + +package-transformers: $(STAMP)/microhs + $(call hackage-at-version,transformers,$(TRANSFORMERS_VERSION)) + cd $(SRC)/transformers-$(TRANSFORMERS_VERSION) && mcabal -q install + +# mtl 2.3.1: MicroHs cannot parse the poly-kinded instance head. +package-mtl: $(STAMP)/microhs + $(call hackage-at-version,mtl,$(MTL_VERSION)) + sed -i 's/^instance forall k (r :: k) (m :: (k -> Type)) \. MonadCont (ContT r m) where/instance MonadCont (ContT r m) where/' \ + $(SRC)/mtl-$(MTL_VERSION)/Control/Monad/Cont/Class.hs + @grep -q '^instance MonadCont (ContT r m) where' \ + $(SRC)/mtl-$(MTL_VERSION)/Control/Monad/Cont/Class.hs || \ + { echo "*** the mtl patch did not apply; check MTL_VERSION"; exit 1; } + cd $(SRC)/mtl-$(MTL_VERSION) && mcabal -q install + +# containers depends on template-haskell only for Lift instances, which are +# never compiled, so an empty package satisfies it. +package-template-haskell: $(STAMP)/microhs + @mkdir -p $(SRC)/template-haskell + @printf '%s\n' \ + 'cabal-version: 2.4' \ + 'name: template-haskell' \ + 'version: 2.22.0.0' \ + 'synopsis: Empty stand-in for template-haskell when building with MicroHs' \ + 'build-type: Simple' \ + '' \ + 'library' \ + ' default-language: Haskell2010' \ + ' build-depends: base' \ + > $(SRC)/template-haskell/template-haskell.cabal + cd $(SRC)/template-haskell && mcabal -q install + +package-containers: $(STAMP)/microhs package-template-haskell + $(call git-at-rev,containers,$(CONTAINERS_URL),$(CONTAINERS_REV)) + cd $(SRC)/containers/containers && mcabal -q install + +##################################################################### +# miso and the sample app + +miso: $(STAMP)/miso +$(STAMP)/miso: $(STAMP)/packages + cd $(CURDIR) && mcabal -q -f"$(MISO_FLAGS)" install + @touch $@ + +app: $(STAMP)/miso $(STAMP)/emsdk + $(EMSDK_ENV); $(MAKE) -C sample-app mhs-mcabal MHS_TARGET=$(MHS_TARGET) + +serve: + cd sample-app/public-mhs && python3 -m http.server $(SERVE_PORT) + +clean: + rm -rf $(WORK) $(CABALDIR) sample-app/public-mhs sample-app/dist-mcabal From b8e45020399a33c305389d6d2bfa60aad74e50ce Mon Sep 17 00:00:00 2001 From: dmjio Date: Mon, 21 Sep 2026 18:52:22 -0500 Subject: [PATCH 13/34] sample-app: replace the counter with a snake game Something with a tick, keyboard input, randomness and a non-trivial amount of state, to exercise more of the runtime than a counter does when testing the MicroHs build. Temporary: the counter is the sample app people are pointed at, so this should not outlive the testing. Needs containers for Data.Sequence (the body) and Data.Set (the occupied cells); both build under mhs. --- sample-app/Main.hs | 596 +++++++++++++++++++++++++++++++++++++++---- sample-app/app.cabal | 2 +- 2 files changed, 544 insertions(+), 54 deletions(-) diff --git a/sample-app/Main.hs b/sample-app/Main.hs index 374138ca4..deaf74c4f 100644 --- a/sample-app/Main.hs +++ b/sample-app/Main.hs @@ -1,74 +1,564 @@ ---------------------------------------------------------------------------- -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StaticPointers #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} ---------------------------------------------------------------------------- module Main where ---------------------------------------------------------------------------- -import Miso +import Control.Concurrent (threadDelay) +import Control.Monad (forever, when) +import Data.Foldable (toList) +import Data.Sequence (Seq, ViewL(..), ViewR(..)) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +---------------------------------------------------------------------------- +import Miso hiding (Phase) +import Miso.CSS hiding (ms, background, Phase) import qualified Miso.Html as H +import qualified Miso.Html.Property as HP +import qualified Miso.Svg as S +import qualified Miso.Svg.Property as SP import Miso.Lens -import Miso.JSON -import GHC.Generics (Generic) ----------------------------------------------------------------------------- --- | Component model state -data Model - = Model - { _counter :: Int - } deriving stock (Show, Eq, Generic) - deriving anyclass (ToJSON, FromJSON) ----------------------------------------------------------------------------- -counter :: Lens Model Int -counter = lens _counter $ \record field -> record { _counter = field } +import Miso.Random (replicateRM) +import Miso.Reload ---------------------------------------------------------------------------- --- | Sum type for App events + +gridSize :: Int +gridSize = 20 + +cellSize :: Int +cellSize = 24 + +boardPx :: Int +boardPx = gridSize * cellSize + +tickInterval :: Double +tickInterval = 120.0 + +-- CSS transition slightly longer than the tick. Real tick spacing is +-- tickInterval plus timer/render slop, so a transition of exactly +-- tickInterval finishes early and leaves a variable per-tick freeze +-- (visible jitter). Overshooting means a late tick interrupts a +-- still-moving linear transition and motion stays continuous; a +-- transition shorter than the tick stutters: move, pause, move. +segTransition :: Style +segTransition = transition ("transform " <> ms (round (tickInterval * 1.25) :: Int) <> "ms linear") + +data Dir = DUp | DDown | DLeft | DRight deriving (Show, Eq) + +data Phase = NotStarted | Playing | GameOver deriving (Show, Eq) + +data Model = Model + { _snake :: !(Seq (Int, Int)) + , _occupied :: !(Set (Int, Int)) + , _dir :: !Dir + , _queued :: ![Dir] + -- up to two pending turns; buffering two lets fast corner combos + -- (e.g. Up then Left within one tick) both register + , _food :: !(Int, Int) + , _score :: !Int + , _phase :: !Phase + , _prevLen :: !Int + -- snake length at start of last tick; suppresses CSS transition on newly-grown segments + , _prevSnake :: !(Seq (Int, Int)) + -- positions from last tick; per-segment jump detection for wall wraps + } deriving (Show, Eq) + +snake :: Lens Model (Seq (Int, Int)) +snake = lens _snake $ \r x -> r { _snake = x } + +occupied :: Lens Model (Set (Int, Int)) +occupied = lens _occupied $ \r x -> r { _occupied = x } + +dir :: Lens Model Dir +dir = lens _dir $ \r x -> r { _dir = x } + +queued :: Lens Model [Dir] +queued = lens _queued $ \r x -> r { _queued = x } + +food :: Lens Model (Int, Int) +food = lens _food $ \r x -> r { _food = x } + +score :: Lens Model Int +score = lens _score $ \r x -> r { _score = x } + +phase :: Lens Model Phase +phase = lens _phase $ \r x -> r { _phase = x } + +prevLen :: Lens Model Int +prevLen = lens _prevLen $ \r x -> r { _prevLen = x } + +prevSnake :: Lens Model (Seq (Int, Int)) +prevSnake = lens _prevSnake $ \r x -> r { _prevSnake = x } + data Action - = AddOne - | SubtractOne - | SayHelloWorld - deriving stock (Show, Eq, Generic) - deriving anyclass (ToJSON, FromJSON) ----------------------------------------------------------------------------- --- | Entry point for a miso application + = Tick + | Turn Dir + | PlaceFood (Int, Int) + | NewGame + | NoOp + deriving (Show, Eq) + main :: IO () #ifdef INTERACTIVE -main = live defaultEvents app +main = reload Miso.pointerEvents app #else -main = startApp defaultEvents app +main = startApp Miso.pointerEvents app #endif ----------------------------------------------------------------------------- --- | WASM export, required when compiling w/ the WASM backend. + #ifdef WASM #ifndef INTERACTIVE foreign export javascript "hs_start" main :: IO () #endif #endif ----------------------------------------------------------------------------- --- | `component` takes as arguments the initial model, update function, view function -app :: App Model Action -app = component emptyModel updateModel viewModel ----------------------------------------------------------------------------- --- | Empty application state + +initSnake :: Seq (Int, Int) +initSnake = Seq.fromList [(10,10),(9,10),(8,10)] + +initOccupied :: Set (Int, Int) +initOccupied = Set.fromList [(10,10),(9,10),(8,10)] + +initFood :: (Int, Int) +initFood = (15,10) + emptyModel :: Model -emptyModel = Model 0 ----------------------------------------------------------------------------- --- | Updates model, optionally introduces side effects -updateModel :: Action -> Effect context props Model Action +emptyModel = Model + { _snake = initSnake + , _occupied = initOccupied + , _dir = DRight + , _queued = [] + , _food = initFood + , _score = 0 + , _phase = NotStarted + , _prevLen = Seq.length initSnake + , _prevSnake = initSnake + } + +app :: App Model Action +app = (component emptyModel updateModel viewModel) + { subs = + [ \sink _ -> forever (threadDelay (round (tickInterval * 1000)) >> sink Tick) + , windowSub "keydown" keycodeDecoder (\case + KeyCode 37 -> Turn DLeft + KeyCode 38 -> Turn DUp + KeyCode 39 -> Turn DRight + KeyCode 40 -> Turn DDown + KeyCode 78 -> NewGame + _ -> NoOp) + ] + } + +opposite :: Dir -> Dir +opposite DUp = DDown +opposite DDown = DUp +opposite DLeft = DRight +opposite DRight = DLeft + +step :: Dir -> (Int, Int) -> (Int, Int) +step DUp (x,y) = (x, (y - 1) `mod` gridSize) +step DDown (x,y) = (x, (y + 1) `mod` gridSize) +step DLeft (x,y) = ((x - 1) `mod` gridSize, y) +step DRight (x,y) = ((x + 1) `mod` gridSize, y) + +pickFood :: Set (Int, Int) -> IO (Int, Int) +pickFood occ = do + [rx, ry] <- replicateRM 2 + let x = floor (rx * fromIntegral gridSize) `mod` gridSize + y = floor (ry * fromIntegral gridSize) `mod` gridSize + if Set.member (x, y) occ then pickFood occ else pure (x, y) + +updateModel :: Action -> Effect parent props Model Action updateModel = \case - AddOne -> counter += 1 - SubtractOne -> counter -= 1 - SayHelloWorld -> io_ (consoleLog "Hello world") + NoOp -> pure () + + NewGame -> do + put emptyModel { _phase = Playing } + io $ pickFood initOccupied >>= pure . PlaceFood + + PlaceFood pos -> food .= pos + + Turn d -> do + m <- get + when (_phase m == NotStarted) (phase .= Playing) + -- validate against the last pending turn (or current dir), so a + -- buffered turn can't be followed by its own reversal + let effective = case _queued m of [] -> _dir m; qs -> last qs + when (d /= opposite effective && d /= effective && length (_queued m) < 2) $ + queued .= _queued m ++ [d] + + Tick -> do + m <- get + case _phase m of + NotStarted -> pure () + GameOver -> pure () + Playing -> do + let (d, rest) = case _queued m of + q:qs -> (q, qs) + [] -> (_dir m, []) + body = _snake m + occ = _occupied m + headPos = case Seq.viewl body of h :< _ -> h; _ -> (0,0) + newHead = step d headPos + self = Set.member newHead occ + dir .= d + queued .= rest + prevLen .= Seq.length body + prevSnake .= body + if self + then phase .= GameOver + else case Seq.viewr body of + EmptyR -> pure () + init' :> tailCell -> do + let ate = newHead == _food m + newBody | ate = newHead Seq.<| body + | otherwise = newHead Seq.<| init' + newOcc | ate = Set.insert newHead occ + | otherwise = Set.insert newHead (Set.delete tailCell occ) + snake .= newBody + occupied .= newOcc + when ate $ do + score += 1 + io $ pickFood newOcc >>= pure . PlaceFood + +---------------------------------------------------------------------------- +-- View ---------------------------------------------------------------------------- --- | Constructs a virtual DOM from a model -viewModel :: Model -> View () () Model Action -viewModel (Model x) = - vfrag - [ H.button_ [ H.onClick AddOne ] [ "+" ] - , text (ms x) - , H.button_ [ H.onClick SubtractOne ] [ "-" ] - ] + +si :: Int -> MisoString +si = ms + +svgCoord :: Int -> Int +svgCoord n = n * cellSize + 1 + +viewModel :: Model -> View context props Model Action +viewModel m = + H.div_ + [ style_ + [ display "flex" + , flexDirection "column" + , alignItems "center" + , justifyContent "center" + , height "100dvh" + , margin "0" + , padding "0" + , backgroundColor (Hex "0d0d1a") + , fontFamily "'Segoe UI', system-ui, monospace" + , boxSizing "border-box" + , overflow "hidden" + ] + ] + + [ H.style_ [] + ( "html,body{margin:0;padding:0;overflow:hidden;overscroll-behavior:none;}" + <> ".board{touch-action:none;width:min(482px,calc(100vw - 16px));height:auto;}" + -- promote animating segments to compositor layers: transform + -- transitions then run off the main thread with no SVG repaint + <> ".seg{will-change:transform;}" + <> ".dpad{display:none;}" + <> "@media(pointer:coarse){.dpad{display:grid!important;}}" + <> "button{-webkit-tap-highlight-color:transparent;user-select:none;-webkit-user-select:none;}" + ) + , H.h1_ + [ style_ + [ margin "0 0 8px 0" + , fontWeight "700" + ] + ] + [ H.a_ + [ HP.href_ "https://github.com/haskell-miso/miso-snake" + , HP.target_ "_blank" + , style_ + [ color (Hex "4ade80") + , fontSize (px 36) + , letterSpacing "0.15em" + , textShadow "0 0 30px rgba(74,222,128,0.6), 0 0 60px rgba(74,222,128,0.2)" + , textDecoration "none" + ] + ] + [ text "\x1F35C miso snake" ] + ] + , H.div_ + [ style_ + [ display "flex" + , gap "32px" + , marginBottom "12px" + , color (Hex "94a3b8") + , fontSize (px 16) + , letterSpacing "0.05em" + ] + ] + [ H.span_ [ style_ [ color (Hex "4ade80"), fontWeight "600" ] ] + [ text ("SCORE " <> ms (_score m)) ] + ] + , board m + , dpad + , H.div_ + [ style_ + [ marginTop "12px" + , color (Hex "475569") + , fontSize (px 12) + , letterSpacing "0.1em" + ] + ] + [ text "ARROWS / D-PAD — MOVE N — NEW GAME" ] + ] + +board :: Model -> View context props Model Action +board m = + S.svg_ + [ HP.class_ "board" + , HP.width_ (si (boardPx + 2)) + , HP.height_ (si (boardPx + 2)) + , SP.viewBox_ ("0 0 " <> si (boardPx + 2) <> " " <> si (boardPx + 2)) + , style_ + [ borderRadius "10px" + , boxShadow "0 0 0 1px #1e2030, 0 0 40px rgba(74,222,128,0.12), 0 20px 60px rgba(0,0,0,0.6)" + ] + ] + ( defs + : background + : gridLines + : renderFood (_food m) + : renderSnake (_prevLen m) (_prevSnake m) (_snake m) + ++ [overlay m] + ) + +defs :: View context props Model Action +defs = + S.defs_ [] + [ S.filter_ + [ HP.id_ "glow", SP.x_ "-50%", SP.y_ "-50%", HP.width_ "200%", HP.height_ "200%" ] + [ S.feGaussianBlur_ [ SP.stdDeviation_ "3", SP.result_ "blur" ] + , S.feMerge_ [] + [ S.feMergeNode_ [ SP.in_' "blur" ] + , S.feMergeNode_ [ SP.in_' "SourceGraphic" ] + ] + ] + , S.filter_ + [ HP.id_ "foodglow", SP.x_ "-80%", SP.y_ "-80%", HP.width_ "260%", HP.height_ "260%" ] + [ S.feGaussianBlur_ [ SP.stdDeviation_ "5", SP.result_ "blur" ] + , S.feMerge_ [] + [ S.feMergeNode_ [ SP.in_' "blur" ] + , S.feMergeNode_ [ SP.in_' "SourceGraphic" ] + ] + ] + , S.radialGradient_ [ HP.id_ "headGrad", SP.cx_ "40%", SP.cy_ "35%", SP.r_ "60%" ] + [ S.stop_ [ SP.offset_ "0%", SP.stopColor_ "#86efac" ] + , S.stop_ [ SP.offset_ "100%", SP.stopColor_ "#16a34a" ] + ] + , S.radialGradient_ [ HP.id_ "bodyGrad", SP.cx_ "40%", SP.cy_ "35%", SP.r_ "60%" ] + [ S.stop_ [ SP.offset_ "0%", SP.stopColor_ "#4ade80" ] + , S.stop_ [ SP.offset_ "100%", SP.stopColor_ "#15803d" ] + ] + , S.radialGradient_ [ HP.id_ "foodGrad", SP.cx_ "35%", SP.cy_ "30%", SP.r_ "65%" ] + [ S.stop_ [ SP.offset_ "0%", SP.stopColor_ "#fb923c" ] + , S.stop_ [ SP.offset_ "100%", SP.stopColor_ "#c2410c" ] + ] + ] + +background :: View context props Model Action +background = + S.g_ [] + [ S.rect_ + [ SP.x_ "0", SP.y_ "0" + , HP.width_ (si (boardPx + 2)), HP.height_ (si (boardPx + 2)) + , SP.rx_ "10", SP.ry_ "10" + , SP.fill_ "#0d0d1a" + ] + , S.rect_ + [ SP.x_ "1", SP.y_ "1" + , HP.width_ (si boardPx), HP.height_ (si boardPx) + , SP.rx_ "6", SP.ry_ "6" + , SP.fill_ "#10101e" + ] + ] + +-- all 38 grid lines as a single : one DOM node to convert, diff +-- and paint per frame instead of 38 +gridLines :: View context props Model Action +gridLines = + S.path_ + [ SP.d_ (ms (concat ( + [ "M" ++ show (svgCoord col) ++ " 1V" ++ show (boardPx + 1) + | col <- [1..gridSize-1] ] ++ + [ "M1 " ++ show (svgCoord row) ++ "H" ++ show (boardPx + 1) + | row <- [1..gridSize-1] ]))) + , SP.fill_ "none" + , SP.stroke_ "#2a3f6f", SP.strokeWidth_ "1" + ] + +renderFood :: (Int, Int) -> View context props Model Action +renderFood (fx, fy) = + let cx = svgCoord fx + cellSize `div` 2 + cy = svgCoord fy + cellSize `div` 2 + r = cellSize `div` 2 - 3 + in S.g_ [ SP.filter_ "url(#foodglow)" ] + [ S.circle_ + [ SP.cx_ (si cx), SP.cy_ (si cy) + , SP.r_ (si r) + , SP.fill_ "url(#foodGrad)" + ] + , S.circle_ + [ SP.cx_ (si (cx - 2)), SP.cy_ (si (cy - 3)) + , SP.r_ "2" + , SP.fill_ "#fde68a" + , SP.opacity_ "0.7" + ] + ] + +-- Head is rendered at list index 0 so Miso always patches the same DOM +-- element for it — CSS transition fires correctly on every tick including +-- eating. Body segments follow head-to-tail; the segment at index >= prevLen +-- is newly grown and gets transition:none so it pops in at the old tail +-- position instead of flying from the SVG origin. +-- key_ is set on every element so Miso uses key-based reconciliation +-- (requires ALL siblings to have keys; without key_ it falls back to +-- position-based matching which also works but is less robust). +-- Suppress transition for a segment whenever its position delta > 1, +-- which happens on the tick a segment steps into a wrapped position. +-- This covers the head on the wrap tick AND every body segment on the +-- subsequent ticks as the wrapped position propagates down the snake. +renderSnake :: Int -> Seq (Int, Int) -> Seq (Int, Int) -> [View context props Model Action] +renderSnake pl prev curr = + let prevList = toList prev ++ repeat (0, 0) + in zipWith3 render [0..] prevList (toList curr) + where + jumped (px, py) (cx, cy) = abs (cx - px) > 1 || abs (cy - py) > 1 + render 0 p c = renderHead (jumped p c) c + render i p c = renderBody (i >= pl || jumped p c) i c + +renderHead :: Bool -> (Int, Int) -> View context props Model Action +renderHead suppress (hx, hy) = + let px = svgCoord hx + py = svgCoord hy + pad = 1 + sz = cellSize - 2 * pad + tx = "translate(" <> ms px <> "px," <> ms py <> "px)" + st | suppress = [ transform tx ] + | otherwise = [ transform tx, segTransition ] + in S.g_ + [ key_ (0 :: Int) + , HP.class_ "seg" + , style_ st + ] + -- glow as layered translucent rects instead of feGaussianBlur: + -- the blur filter forced a repaint on every frame of the + -- transition, causing visible hitching + [ S.rect_ + [ SP.x_ (si (pad - 4)), SP.y_ (si (pad - 4)) + , HP.width_ (si (sz + 8)), HP.height_ (si (sz + 8)) + , SP.rx_ "10", SP.ry_ "10" + , SP.fill_ "#4ade80", SP.opacity_ "0.15" + ] + , S.rect_ + [ SP.x_ (si (pad - 2)), SP.y_ (si (pad - 2)) + , HP.width_ (si (sz + 4)), HP.height_ (si (sz + 4)) + , SP.rx_ "8", SP.ry_ "8" + , SP.fill_ "#4ade80", SP.opacity_ "0.25" + ] + , S.rect_ + [ SP.x_ (si pad), SP.y_ (si pad) + , HP.width_ (si sz), HP.height_ (si sz) + , SP.rx_ "6", SP.ry_ "6" + , SP.fill_ "url(#headGrad)" + ] + ] + +renderBody :: Bool -> Int -> (Int, Int) -> View context props Model Action +renderBody isNew i (bx, by) = + let px = svgCoord bx + py = svgCoord by + pad = 2 + sz = cellSize - 2 * pad + tx = "translate(" <> ms px <> "px," <> ms py <> "px)" + st | isNew = [ transform tx ] + | otherwise = [ transform tx, segTransition ] + in S.g_ + [ key_ i + , HP.class_ "seg" + , style_ st + ] + [ S.rect_ + [ SP.x_ (si pad), SP.y_ (si pad) + , HP.width_ (si sz), HP.height_ (si sz) + , SP.rx_ "4", SP.ry_ "4" + , SP.fill_ "url(#bodyGrad)" + ] + ] + +overlay :: Model -> View context props Model Action +overlay m = case _phase m of + Playing -> S.g_ [] [] + NotStarted -> overlayBox "TAP TO BEGIN" "OR PRESS AN ARROW KEY" "#4ade80" (Turn DRight) + GameOver -> overlayBox "GAME OVER" "TAP OR PRESS N" "#f87171" NewGame + +overlayBox :: MisoString -> MisoString -> MisoString -> Action -> View context props Model Action +overlayBox title sub clr act = + S.g_ [ H.onPointerDown (const act), style_ [ cursor "pointer" ] ] + [ S.rect_ + [ SP.x_ "0", SP.y_ "0" + , HP.width_ (si (boardPx + 2)), HP.height_ (si (boardPx + 2)) + , SP.rx_ "10", SP.ry_ "10" + , SP.fill_ "rgba(10,10,20,0.82)" + ] + , S.text_ + [ SP.x_ (si ((boardPx + 2) `div` 2)) + , SP.y_ (si ((boardPx + 2) `div` 2 - 20)) + , SP.textAnchor_ "middle" + , SP.dominantBaseline_ "middle" + , SP.fill_ clr + , SP.fontSize_ "26" + , SP.fontWeight_ "700" + , SP.letterSpacing_ "4" + , SP.filter_ "url(#glow)" + ] [ text title ] + , S.text_ + [ SP.x_ (si ((boardPx + 2) `div` 2)) + , SP.y_ (si ((boardPx + 2) `div` 2 + 20)) + , SP.textAnchor_ "middle" + , SP.dominantBaseline_ "middle" + , SP.fill_ "#94a3b8" + , SP.fontSize_ "13" + , SP.letterSpacing_ "2" + ] [ text sub ] + ] + +dpad :: View context props Model Action +dpad = + H.div_ + [ HP.class_ "dpad" + , style_ + [ gridTemplateColumns "repeat(3, 56px)" + , gridTemplateRows "repeat(3, 56px)" + , gap "4px" + , marginTop "12px" + ] + ] + [ H.div_ [] [], btn DUp "\x25b2", H.div_ [] [] + , btn DLeft "\x25c4", H.div_ [] [], btn DRight "\x25ba" + , H.div_ [] [], btn DDown "\x25bc", H.div_ [] [] + ] + where + btn d lbl = + H.button_ + [ H.onPointerDown (const (Turn d)) + , style_ + [ width "100%" + , height "100%" + , borderRadius "10px" + , backgroundColor (RGBA 74 222 128 0.12) + , border "1px solid rgba(74,222,128,0.25)" + , color (Hex "4ade80") + , fontSize (px 20) + , cursor "pointer" + , display "flex" + , alignItems "center" + , justifyContent "center" + , padding "0" + , boxSizing "border-box" + ] + ] + [ text lbl ] ---------------------------------------------------------------------------- diff --git a/sample-app/app.cabal b/sample-app/app.cabal index 8d98775d8..9afbb06f1 100644 --- a/sample-app/app.cabal +++ b/sample-app/app.cabal @@ -46,6 +46,6 @@ executable app main-is: Main.hs build-depends: - base, miso + base, miso, containers default-language: Haskell2010 From ee035d64b3a8133febbbd7750976cb437fb4bdbd Mon Sep 17 00:00:00 2001 From: dmjio Date: Mon, 21 Sep 2026 23:04:42 -0500 Subject: [PATCH 14/34] Makefile.mhs: bump MicroHs to the upstream merge (0.16.6.0) MicroHs rts-standalone merged augustss/master, so the compiler is now 0.16.6.0 (the package database path depends on the version) and targets.conf is called mhs.conf. --- Makefile.mhs | 6 +++--- sample-app/Makefile | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Makefile.mhs b/Makefile.mhs index be2dd906d..3da705374 100644 --- a/Makefile.mhs +++ b/Makefile.mhs @@ -21,12 +21,12 @@ # Revisions are kept in step with nix/source.nix -- change them in both. ##################################################################### -MHS_VERSION := 0.15.3.0 +MHS_VERSION := 0.16.6.0 # MicroHs with the JSVal/JavaScript FFI and browser targets: dmjio/MicroHs, # branch rts-standalone. Upstream augustss/MicroHs will not work. MICROHS_URL := https://github.com/dmjio/MicroHs -MICROHS_REV := 2a16a58db5b2ea66ca7bbb29aa097201c376803f +MICROHS_REV := a75a4d60ebf86ac0307a3d410f7f43b3d25a09cd GHC_COMPAT_URL := https://github.com/augustss/ghc-compat GHC_COMPAT_REV := e04bd70e4040d52cd1d319387bda7514000b58a0 @@ -41,7 +41,7 @@ MTL_VERSION := 2.3.1 # miso's cabal flags under mhs (see nix/mhs/default.nix). MISO_FLAGS := -template-haskell -aeson -native -production -ssr -benchmark text -# The section of MicroHs's targets.conf to compile for: browser +# The section of MicroHs's mhs.conf to compile for: browser # (WebAssembly) or browser_js (JavaScript only, -sWASM=0). MHS_TARGET ?= browser diff --git a/sample-app/Makefile b/sample-app/Makefile index 429d5c436..822381d81 100644 --- a/sample-app/Makefile +++ b/sample-app/Makefile @@ -56,7 +56,7 @@ build-js86: cp -rv static public # Build with MicroHs (mhs) for the browser, via emscripten. -# MHS_TARGET is a section of MicroHs's targets.conf: browser (WebAssembly) +# MHS_TARGET is a section of MicroHs's mhs.conf: browser (WebAssembly) # or browser_js (JavaScript only, -sWASM=0). MHS_TARGET=browser # -js embeds js/miso.js in the output (like js-sources in miso.cabal when built with mcabal) From 780edc34ca3d37d90aff508e82c8cc4850d6bcb8 Mon Sep 17 00:00:00 2001 From: dmjio Date: Fri, 25 Sep 2026 13:14:55 -0500 Subject: [PATCH 15/34] Bump MicroHs (callback fixes) and follow its version to 0.16.6.0 The MicroHs merge with upstream moved the version from 0.15.3.0 to 0.16.6.0, and nix/mhs/default.nix builds the package database path from it, so mcabal installed packages in mhs-0.16.6.0 while mhs was told to look in mhs-0.15.3.0 and reported 'dependency not installed: ghc-compat'. --- nix/mhs/default.nix | 2 +- nix/source.nix | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/nix/mhs/default.nix b/nix/mhs/default.nix index 4c650c9b6..aad5694dc 100644 --- a/nix/mhs/default.nix +++ b/nix/mhs/default.nix @@ -8,7 +8,7 @@ self: super: let src = import ../source.nix super; - version = "0.15.3.0"; + version = "0.16.6.0"; # Package database of a derivation, as seen by mhs/mcabal. cabalDir = drv: "${drv}/lib/mcabal"; mhsDir = drv: "${cabalDir drv}/mhs-${version}"; diff --git a/nix/source.nix b/nix/source.nix index aae8e1fb6..591659810 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "4f377101aaa0c3fff413297561d27987c45fd82e"; - hash = "sha256-3MzZ3AWyeW5EtwFIMn8uCMq14A5QUg4ySnhXffu/fjw="; + rev = "aca1212f7ca919ff7f7fde485c4fa0ed483b4d28"; + hash = "sha256-VA/haV6vwsOndKy2cKVJxwrJK1aMEVvA+naoOIa8iqI="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; From 3b57158c692511e77b0786387c9cbc6a0d977bcd Mon Sep 17 00:00:00 2001 From: dmjio Date: Fri, 25 Sep 2026 14:55:48 -0500 Subject: [PATCH 16/34] Bump MicroHs: enable ASYNCIFY when a program creates JavaScript callbacks --- nix/source.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/nix/source.nix b/nix/source.nix index 51a1531d6..12bf40ac8 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "d58bb4ebd825f29470e7047d61cc4adc7e95d67f"; - hash = "sha256-P7EN+sxcUcl6nw6EV128CYxhhtyoXKMy6FVIm7pc71M="; + rev = "31f4598607b6803fb02fd2ff8f04118f4107cb10"; + hash = "sha256-ni0WXEsrDtkYrirq260uUStST85S8HUAuygqEnJGnX4="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; From 4e6fa70a771c15af5ae20ca301c34bfae8c991c8 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 15:02:49 -0500 Subject: [PATCH 17/34] CI: run the MicroHs integration tests with browser_js too The mhs test bundle is now built per mhs.conf target: browser (WebAssembly, playwright-mhs) and browser_js (JavaScript only, -sWASM=0, playwright-mhs-js). The workflow runs both. --- .github/workflows/main.yml | 8 +++++++- default.nix | 19 +++++++++++++++++-- nix/mhs/default.nix | 10 +++++++--- nix/overlay.nix | 2 +- 4 files changed, 32 insertions(+), 7 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index a1d536f39..609bf3912 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -103,12 +103,18 @@ jobs: - name: (WASM) Miso integration tests run: nix-build -A playwright-wasm && ./result/bin/playwright - - name: (MHS) Miso integration tests built with MicroHs + - name: (MHS WASM) Miso integration tests built with MicroHs (browser) run: nix-build -A playwright-mhs && ./result/bin/playwright - name: Nix garbage collection run: cabal clean && nix-collect-garbage -d + - name: (MHS JS) Miso integration tests built with MicroHs (browser_js) + run: nix-build -A playwright-mhs-js && ./result/bin/playwright + + - name: Nix garbage collection + run: cabal clean && nix-collect-garbage -d + - name: (WASM) Miso integration tests (aeson) run: nix-build -A playwright-wasm-aeson && ./result/bin/playwright diff --git a/default.nix b/default.nix index 1817ca4f0..52364ec25 100644 --- a/default.nix +++ b/default.nix @@ -193,8 +193,9 @@ rec { ''; # Same as playwright-wasm, but miso and the integration tests are built with - # MicroHs (mhs), see nix/mhs/default.nix. - inherit (pkgs) microhs microhs-packages miso-mhs sample-app-mhs-bundle miso-tests-mhs-bundle; + # MicroHs (mhs), see nix/mhs/default.nix. playwright-mhs uses the mhs + # target browser (WebAssembly), playwright-mhs-js browser_js (JavaScript). + inherit (pkgs) microhs microhs-packages miso-mhs sample-app-mhs-bundle miso-tests-mhs-bundle miso-tests-mhs-js-bundle; playwright-mhs = pkgs.writeScriptBin "playwright" '' #!${pkgs.stdenv.shell} export PLAYWRIGHT_BROWSERS_PATH=${pkgs.playwright-driver.browsers} @@ -209,6 +210,20 @@ rec { pkill -f echo-server exit "$exit_code" ''; + playwright-mhs-js = pkgs.writeScriptBin "playwright" '' + #!${pkgs.stdenv.shell} + export PLAYWRIGHT_BROWSERS_PATH=${pkgs.playwright-driver.browsers} + export PATH="${pkgs.lib.makeBinPath [ pkgs.http-server pkgs.bun ]}:$PATH" + bun install playwright@${pkgs.playwright-driver.version} + http-server ${pkgs.miso-tests-mhs-js-bundle} & + bun run ts/echo-server.ts & + cd tests + bun run ../ts/playwright.ts + exit_code=$? + pkill http-server + pkill -f echo-server + exit "$exit_code" + ''; # Same as playwright-wasm, but miso is built with the 'aeson' cabal flag # (Miso.JSON defined in terms of Data.Aeson). Nix-native now (see diff --git a/nix/mhs/default.nix b/nix/mhs/default.nix index b340d3cf2..20aeb00d3 100644 --- a/nix/mhs/default.nix +++ b/nix/mhs/default.nix @@ -136,8 +136,12 @@ rec { # The integration tests (tests/app/Main.hs) built with mhs for the browser, # driven by ts/playwright.ts (see playwright-mhs in default.nix). - miso-tests-mhs-bundle = super.stdenv.mkDerivation { - pname = "miso-tests-mhs-bundle"; + # target is a section of mhs.conf: browser (WebAssembly) or browser_js + # (JavaScript only, -sWASM=0). + miso-tests-mhs-bundle = mkTestsBundle "browser"; + miso-tests-mhs-js-bundle = mkTestsBundle "browser_js"; + mkTestsBundle = target: super.stdenv.mkDerivation { + pname = "miso-tests-mhs-bundle-${target}"; version = "1.14.0.0"; src = src.miso-tests; nativeBuildInputs = [ microhs super.emscripten ]; @@ -150,7 +154,7 @@ rec { export EM_CACHE=$TMPDIR/emcache cp -r ${super.emscripten}/share/emscripten/cache $EM_CACHE chmod -R u+w $EM_CACHE - ${mcabal} --options=-tbrowser build + ${mcabal} --options=-t${target} build runHook postBuild ''; installPhase = '' diff --git a/nix/overlay.nix b/nix/overlay.nix index beecf6d48..e22df0b05 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -15,7 +15,7 @@ in inherit (js) rspeedy; # MicroHs (mhs) toolchain, the sample app and the tests built with it, see nix/mhs/default.nix - inherit (import ./mhs self super) microhs microhs-packages miso-mhs sample-app-mhs-bundle miso-tests-mhs-bundle; + inherit (import ./mhs self super) microhs microhs-packages miso-mhs sample-app-mhs-bundle miso-tests-mhs-bundle miso-tests-mhs-js-bundle; # Reusable Lynx bundler (GHC-JS app -> .lynx.bundle). `self` is the final # overlayed pkgs, so it already has rspeedy/bun. See nix/lib/mk-lynx-bundle.nix. From 4203569be0d920b26fe3a853ae49dc80782a99f6 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 16:00:04 -0500 Subject: [PATCH 18/34] Move the CPP pragma below the module header line --- src/Miso/CSS/Color.hs | 2 +- src/Miso/Cookie.hs | 2 +- src/Miso/Data/Array.hs | 2 +- src/Miso/Data/Map.hs | 2 +- src/Miso/Data/Set.hs | 2 +- src/Miso/Event.hs | 2 +- src/Miso/Event/Types.hs | 2 +- src/Miso/Lens.hs | 2 +- src/Miso/Lens/TH.hs | 2 +- src/Miso/Media.hs | 2 +- src/Miso/Native/FFI.hs | 2 +- src/Miso/Native/MainThread.hs | 2 +- src/Miso/Router.hs | 2 +- src/Miso/Subscription/Cookie.hs | 2 +- src/Miso/Subscription/History.hs | 2 +- src/Miso/Subscription/Window.hs | 2 +- src/Miso/Util/Lexer.hs | 2 +- 17 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Miso/CSS/Color.hs b/src/Miso/CSS/Color.hs index f93d5367f..e130c235e 100644 --- a/src/Miso/CSS/Color.hs +++ b/src/Miso/CSS/Color.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Miso/Cookie.hs b/src/Miso/Cookie.hs index 84ac63e7a..4014cbc7d 100644 --- a/src/Miso/Cookie.hs +++ b/src/Miso/Cookie.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- diff --git a/src/Miso/Data/Array.hs b/src/Miso/Data/Array.hs index 43b592f53..d04120b29 100644 --- a/src/Miso/Data/Array.hs +++ b/src/Miso/Data/Array.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} diff --git a/src/Miso/Data/Map.hs b/src/Miso/Data/Map.hs index 31b3ff3cc..d48216fa0 100644 --- a/src/Miso/Data/Map.hs +++ b/src/Miso/Data/Map.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- diff --git a/src/Miso/Data/Set.hs b/src/Miso/Data/Set.hs index b77db8b4c..76a242ce4 100644 --- a/src/Miso/Data/Set.hs +++ b/src/Miso/Data/Set.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- diff --git a/src/Miso/Event.hs b/src/Miso/Event.hs index a50aeeb7f..320b2d8a7 100644 --- a/src/Miso/Event.hs +++ b/src/Miso/Event.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} diff --git a/src/Miso/Event/Types.hs b/src/Miso/Event/Types.hs index c0a5805eb..fe1b222db 100644 --- a/src/Miso/Event/Types.hs +++ b/src/Miso/Event/Types.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/Miso/Lens.hs b/src/Miso/Lens.hs index 5d271310b..0c15de53f 100644 --- a/src/Miso/Lens.hs +++ b/src/Miso/Lens.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Miso/Lens/TH.hs b/src/Miso/Lens/TH.hs index 841ae71fa..139ffa2e6 100644 --- a/src/Miso/Lens/TH.hs +++ b/src/Miso/Lens/TH.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskellQuotes #-} ----------------------------------------------------------------------------- diff --git a/src/Miso/Media.hs b/src/Miso/Media.hs index 8075b7c50..4d00e5886 100644 --- a/src/Miso/Media.hs +++ b/src/Miso/Media.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- diff --git a/src/Miso/Native/FFI.hs b/src/Miso/Native/FFI.hs index f0d2e0f61..e00e045e4 100644 --- a/src/Miso/Native/FFI.hs +++ b/src/Miso/Native/FFI.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Miso/Native/MainThread.hs b/src/Miso/Native/MainThread.hs index 19ef6adf9..3ea4c66fd 100644 --- a/src/Miso/Native/MainThread.hs +++ b/src/Miso/Native/MainThread.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} diff --git a/src/Miso/Router.hs b/src/Miso/Router.hs index 07502473c..46e2e9e36 100644 --- a/src/Miso/Router.hs +++ b/src/Miso/Router.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DerivingStrategies #-} diff --git a/src/Miso/Subscription/Cookie.hs b/src/Miso/Subscription/Cookie.hs index 6a9831c24..255499a09 100644 --- a/src/Miso/Subscription/Cookie.hs +++ b/src/Miso/Subscription/Cookie.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Miso/Subscription/History.hs b/src/Miso/Subscription/History.hs index b279fa20c..78bd5184b 100644 --- a/src/Miso/Subscription/History.hs +++ b/src/Miso/Subscription/History.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Miso/Subscription/Window.hs b/src/Miso/Subscription/Window.hs index 9c05e550c..dbefbb1ef 100644 --- a/src/Miso/Subscription/Window.hs +++ b/src/Miso/Subscription/Window.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- diff --git a/src/Miso/Util/Lexer.hs b/src/Miso/Util/Lexer.hs index 4bd2eb5be..63ae8d1fb 100644 --- a/src/Miso/Util/Lexer.hs +++ b/src/Miso/Util/Lexer.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} -- | -- Module : Miso.Util.Lexer -- Copyright : (C) 2016-2026 David M. Johnson From 4d635d8edba003d6ecdb9795132a6781b4405098 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 17:52:54 -0500 Subject: [PATCH 19/34] Bump MicroHs: throwTo waits until the exception is raised in the target Fixes two flaky MicroHs integration tests: a killed scheduler thread could still consume the next test's redraw notification. --- Makefile.mhs | 2 +- nix/source.nix | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile.mhs b/Makefile.mhs index d119ac226..7251403e6 100644 --- a/Makefile.mhs +++ b/Makefile.mhs @@ -26,7 +26,7 @@ MHS_VERSION := 0.16.6.0 # MicroHs with the JSVal/JavaScript FFI and browser targets: dmjio/MicroHs, # branch rts-standalone. Upstream augustss/MicroHs will not work. MICROHS_URL := https://github.com/dmjio/MicroHs -MICROHS_REV := d58bb4ebd825f29470e7047d61cc4adc7e95d67f +MICROHS_REV := 05240a5cc9407b946a471fa0a8c039d7adbc319c GHC_COMPAT_URL := https://github.com/augustss/ghc-compat GHC_COMPAT_REV := e04bd70e4040d52cd1d319387bda7514000b58a0 diff --git a/nix/source.nix b/nix/source.nix index 12bf40ac8..55d9ce734 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "31f4598607b6803fb02fd2ff8f04118f4107cb10"; - hash = "sha256-ni0WXEsrDtkYrirq260uUStST85S8HUAuygqEnJGnX4="; + rev = "05240a5cc9407b946a471fa0a8c039d7adbc319c"; + hash = "sha256-K6HfJAyPJ/rVUAyShBrRarHxuhe7mTLYGlMjAaYycys="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; From 7a3da7688b5e3f8e1f4635f5bce299ff28e8d54c Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 18:10:52 -0500 Subject: [PATCH 20/34] URI: hand-written ToJSVal/ToObject under MicroHs The Generic defaults of ToJSVal/ToObject are not compiled under __MHS__, so the derived instances had no methods and failed at runtime. --- src/Miso/Types.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/Miso/Types.hs b/src/Miso/Types.hs index 1e65a3c8a..5c945c25c 100644 --- a/src/Miso/Types.hs +++ b/src/Miso/Types.hs @@ -1303,7 +1303,20 @@ data URI , uriQueryString :: M.Map MisoString (Maybe MisoString) -- ^ Query parameters. @'Just' v@ for @?key=v@ pairs; 'Nothing' for bare flags (@?flag@). } deriving stock (Show, Eq, Generic) +#ifndef __MHS__ deriving anyclass (ToJSVal, ToObject) +#else +-- MicroHs has no Generic-based defaults +instance ToObject URI where + toObject URI {..} = do + o <- create + setField o "uriPath" =<< toJSVal uriPath + setField o "uriFragment" =<< toJSVal uriFragment + setField o "uriQueryString" =<< toJSVal uriQueryString + pure o +instance ToJSVal URI where + toJSVal uri = toJSVal =<< toObject uri +#endif ---------------------------------------------------------------------------- -- | Empty t'URI'. emptyURI :: URI From 6802ef226b465af00f2afb8ec7cf3ceb5df05a00 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 18:10:52 -0500 Subject: [PATCH 21/34] sample-app: end the game when the snake fills the board pickFood retries until it finds a free cell, so with none left it looped forever. --- sample-app/Main.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/sample-app/Main.hs b/sample-app/Main.hs index deaf74c4f..e6a388337 100644 --- a/sample-app/Main.hs +++ b/sample-app/Main.hs @@ -220,7 +220,10 @@ updateModel = \case occupied .= newOcc when ate $ do score += 1 - io $ pickFood newOcc >>= pure . PlaceFood + -- a full board has no free cell for pickFood to find + if Set.size newOcc == gridSize * gridSize + then phase .= GameOver + else io $ pickFood newOcc >>= pure . PlaceFood ---------------------------------------------------------------------------- -- View From f50d84c1954672ee4280df1b8fa90326e1f820a1 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 18:39:25 -0500 Subject: [PATCH 22/34] tests: run the non-Generic JSON and Router tests under MicroHs Only the tests that need Generic-derived instances are excluded now; the Point, encodePure escaping, fromMisoStringEither and lexTokens tests run with mhs too. --- tests/app/Main.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/tests/app/Main.hs b/tests/app/Main.hs index d06284231..fddc01343 100644 --- a/tests/app/Main.hs +++ b/tests/app/Main.hs @@ -737,8 +737,8 @@ main = withJS $ do decodePure "{\"a\":true,\"b\":1.1}" `shouldBe` Right (JSON.object [("a",JSON.Bool True),("b",JSON.Number 1.1)]) -#ifndef __MHS__ describe "Miso.JSON generic encoding tests" $ do +#ifndef __MHS__ -- Nullary sum constructors → bare String (allNullaryToStringTag = True) it "encodes nullary sum constructors as bare strings" $ do JSON.toJSON Red `shouldBe` JSON.String "Red" @@ -748,6 +748,7 @@ main = withJS $ do (JSON.fromJSON (JSON.toJSON Red) :: JSON.Result Color) `shouldBe` JSON.Success Red (JSON.fromJSON (JSON.toJSON Green) :: JSON.Result Color) `shouldBe` JSON.Success Green (JSON.fromJSON (JSON.toJSON Blue) :: JSON.Result Color) `shouldBe` JSON.Success Blue +#endif -- Single-constructor record → flat object, no tag it "encodes single-constructor records as flat objects" $ do JSON.toJSON (Point 3 4) @@ -755,6 +756,7 @@ main = withJS $ do it "round-trips single-constructor records" $ do (JSON.fromJSON (JSON.toJSON (Point 3 4)) :: JSON.Result Point) `shouldBe` JSON.Success (Point 3 4) +#ifndef __MHS__ -- Single-constructor positional → unwrapped value it "encodes single-constructor positional as unwrapped value" $ do JSON.toJSON (Wrapper 42) `shouldBe` JSON.Number 42 @@ -892,6 +894,7 @@ main = withJS $ do -- decoding with matching opts succeeds JSON.parseEither (JSON.genericParseJSON opts) val `shouldBe` Right (CamelRecord "John" "Doe") +#endif -- #7: full string round-trip via encodePure / decodePure it "round-trips Point through encodePure/decodePure" $ do let s = JSON.encodePure (Point 7 8) @@ -901,6 +904,7 @@ main = withJS $ do JSON.Success x -> Right (x :: Point) JSON.Error e -> Left (S.unpack e) result `shouldBe` Right (Point 7 8) +#ifndef __MHS__ it "round-trips Animal through encodePure/decodePure" $ do let s = JSON.encodePure (Cat "Mittens" 9) result = do @@ -934,6 +938,7 @@ main = withJS $ do `shouldSatisfy` \case JSON.Error _ -> True _ -> False +#endif -- #10: encodePure escapes special characters in strings (Bug 2 fix) it "encodePure escapes double quotes in strings" $ do JSON.encodePure (JSON.String "say \"hello\"") @@ -945,7 +950,6 @@ main = withJS $ do JSON.encodePure (JSON.object [("ke\"y", JSON.Bool True)]) `shouldBe` "{\"ke\\\"y\":true}" -#endif -- toJSONList: String (i.e. [Char]) serializes as a JSON string while -- other lists serialize as JSON arrays. This replaces the old -- OVERLAPPING/OVERLAPPABLE ToJSON String / ToJSON [a] instances. @@ -1190,8 +1194,8 @@ main = withJS $ do describe "Inline JS tests" $ do it "Should use inline js" $ do (`shouldBe` 42) =<< liftIO (getAge (Person "larry" 42)) -#ifndef __MHS__ describe "Router tests" $ do +#ifndef __MHS__ it "should call fromRoute on Index" $ do fromRoute Index `shouldBe` [ IndexToken ] it "should call fromRoute on Home" $ do @@ -1216,8 +1220,10 @@ main = withJS $ do , uriFragment = "" , uriQueryString = M.fromList [("bar", Just "12"), ("lol", Just "11")] } +#endif it "should call fromMisoString on Int" $ do S.fromMisoStringEither "10" `shouldBe` Right (10 :: Int) +#ifndef __MHS__ it "should call href on Index" $ do Miso.Router.href_ Index `shouldBe` Property "href" "/" it "should call href on Home" $ do @@ -1249,6 +1255,7 @@ main = withJS $ do -- toRoute "/widget/10/foo/other?bar=12&lol=11" -- `shouldBe` -- Right (Widget (Capture 10) (Path "foo") (Capture "other") (QueryParam (Just 12)) (QueryParam (Just 11))) +#endif it "should lexTokens on query params/flags" $ do lexTokens "/foo?bar=12" `shouldBe` @@ -1260,7 +1267,6 @@ main = withJS $ do lexTokens "/foo?bar#cool" `shouldBe` Right [CaptureOrPathToken "foo", QueryParamToken "bar" Nothing, FragmentToken "cool"] -#endif describe "MisoString tests" $ do it "Should pack" $ do S.unpack (S.pack "foo") `shouldBe` From 3a2ee5731e42eea41fe31a60709f49ba6b468bd7 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 18:39:26 -0500 Subject: [PATCH 23/34] tests: marshal a URI with toJSVal and toObject --- tests/app/Main.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/app/Main.hs b/tests/app/Main.hs index fddc01343..80660ea34 100644 --- a/tests/app/Main.hs +++ b/tests/app/Main.hs @@ -1764,6 +1764,16 @@ main = withJS $ do (`shouldBe` Just ("foo" :: String)) =<< liftIO (fromJSVal =<< toJSVal ("foo" :: String)) it "Should marshal a Text" $ do (`shouldBe` Just ("foo" :: Text)) =<< liftIO (fromJSVal =<< toJSVal ("foo" :: Text)) + it "Should marshal a URI (toJSVal and toObject)" $ do + let uri = URI "a/b" "frag" (M.fromList [("q", Just "1")]) + field o k = liftIO (fromJSValUnchecked =<< o ! k) + check o = do + (`shouldBe` ("a/b" :: MisoString)) =<< field o "uriPath" + (`shouldBe` ("frag" :: MisoString)) =<< field o "uriFragment" + qs <- liftIO (o ! "uriQueryString") + (`shouldBe` ("1" :: MisoString)) =<< field qs "q" + check =<< liftIO (toJSVal uri) + check =<< liftIO (unObject <$> toObject uri) describe "StaticKey / Fingerprint tests" $ do it "serializes Fingerprint 0 0 as 32 zero hex chars" $ do From 6474a6bc2efd686ebc9e1daea9410620d00bbb0f Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 18:39:26 -0500 Subject: [PATCH 24/34] mhs: parseDouble in one pass, like Data.Text.Read.double Trying readMaybe on every prefix was quadratic and accepted Haskell syntax such as "(5)" and "NaN" that the wasm backend rejects. --- ffi/mhs/Miso/DSL/FFI.hs | 38 +++++++++++++++++++++++--------------- 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/ffi/mhs/Miso/DSL/FFI.hs b/ffi/mhs/Miso/DSL/FFI.hs index be0cd8074..e9e67b4c9 100644 --- a/ffi/mhs/Miso/DSL/FFI.hs +++ b/ffi/mhs/Miso/DSL/FFI.hs @@ -104,14 +104,12 @@ module Miso.DSL.FFI ) where ----------------------------------------------------------------------------- import Control.Monad -import Data.Char (isSpace) -import qualified Data.List as L +import Data.Char (isDigit, isSpace) import Data.List (dropWhileEnd) import Data.Text (Text) import qualified Data.Text as T import Numeric (readHex) import Prelude hiding (length) -import Text.Read (readMaybe) ----------------------------------------------------------------------------- import GHC.Wasm.Prim ----------------------------------------------------------------------------- @@ -382,21 +380,31 @@ parseInt input = applySign <$> digits unsigned parseWord :: Text -> Maybe Word parseWord string = fromIntegral <$> parseInt string ----------------------------------------------------------------------------- --- | Parses like JS's @parseFloat@: leading\/trailing whitespace and --- trailing garbage are ignored, and a leading @+\/-@ is allowed. +-- | Parses like @Data.Text.Read.double@ (as the wasm backend does): +-- surrounding whitespace and trailing garbage are ignored, a leading +-- @+\/-@ is allowed, and there must be at least one integer digit. parseDouble :: Text -> Maybe Double parseDouble input = - case stripped of - ('+' : rest) -> go rest - _ -> go stripped + case T.unpack (T.strip input) of + ('-' : rest) -> negate <$> unsigned rest + ('+' : rest) -> unsigned rest + s -> unsigned s where - stripped = dropWhile isSpace (T.unpack input) - -- Try successively shorter prefixes, so trailing garbage is ignored. - go s = firstJust [ readMaybe p | p <- reverse (prefixes s) ] - prefixes s = [ take n s | n <- [1 .. L.length s] ] - firstJust (Just x : _) = Just x - firstJust (_ : xs) = firstJust xs - firstJust [] = Nothing + unsigned s = + case span isDigit s of + ("", _) -> Nothing + (int, rest) -> + let (frac, rest') = fraction rest + in Just (read (int ++ frac ++ expo rest')) + fraction ('.' : ds) | (f@(_:_), r) <- span isDigit ds = ('.' : f, r) + fraction r = ("", r) + expo (e : ds) | e == 'e' || e == 'E' = + case ds of + ('-' : xs) | (x@(_:_), _) <- span isDigit xs -> "e-" ++ x + ('+' : xs) | (x@(_:_), _) <- span isDigit xs -> 'e' : x + _ | (x@(_:_), _) <- span isDigit ds -> 'e' : x + _ -> "" + expo _ = "" ----------------------------------------------------------------------------- parseFloat :: Text -> Maybe Float parseFloat string = realToFrac <$> parseDouble string From 45932318ea6af4c112fee6550b493ef84f3448c5 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 18:39:26 -0500 Subject: [PATCH 25/34] Remove dead and redundant nested __MHS__ guards --- src/Miso/DSL.hs | 12 ------------ src/Miso/Media.hs | 4 ---- src/Miso/Native/FFI.hs | 2 -- src/Miso/Subscription/History.hs | 2 -- src/Miso/Subscription/Window.hs | 2 -- src/Miso/Util/Lexer.hs | 2 -- 6 files changed, 24 deletions(-) diff --git a/src/Miso/DSL.hs b/src/Miso/DSL.hs index 1741f0583..050662a0c 100644 --- a/src/Miso/DSL.hs +++ b/src/Miso/DSL.hs @@ -191,12 +191,8 @@ import GHC.Generics import GHC.TypeLits import Data.Kind #ifdef __MHS__ -#ifdef __MHS__ import Prelude hiding (mapM, mapM_, sequence, sequence_, setField, (!!)) #else -import Prelude hiding (setField, (!!)) -#endif -#else import Prelude hiding ((!!)) #endif ----------------------------------------------------------------------------- @@ -234,11 +230,7 @@ instance (GToJSVal a, GToJSVal b) => GToJSVal (a :*: b) where gToJSVal (x :*: y) o = gToJSVal x o >> gToJSVal y o {-# INLINE gToJSVal #-} ----------------------------------------------------------------------------- -#ifdef __MHS__ -instance (GToJSVal a, GToJSVal b) => GToJSVal (a :+: b) where -#else instance (TypeError ('Text "Sum types unsupported"), GToJSVal a, GToJSVal b) => GToJSVal (a :+: b) where -#endif gToJSVal = \case L1 x -> gToJSVal x R1 x -> gToJSVal x @@ -381,11 +373,7 @@ instance (GFromJSVal a, GFromJSVal b) => GFromJSVal (a :*: b) where gFromJSVal o = runMaybeT $ (:*:) <$> MaybeT (gFromJSVal o) <*> MaybeT (gFromJSVal o) {-# INLINE gFromJSVal #-} ----------------------------------------------------------------------------- -#ifdef __MHS__ -instance (GFromJSVal a, GFromJSVal b) => GFromJSVal (a :+: b) where -#else instance (TypeError ('Text "Sum types unsupported"), GFromJSVal a, GFromJSVal b) => GFromJSVal (a :+: b) where -#endif gFromJSVal o = do x <- fmap L1 <$> gFromJSVal o case x of diff --git a/src/Miso/Media.hs b/src/Miso/Media.hs index 4d00e5886..61efc9916 100644 --- a/src/Miso/Media.hs +++ b/src/Miso/Media.hs @@ -121,11 +121,7 @@ module Miso.Media ) where ----------------------------------------------------------------------------- #ifdef __MHS__ -#ifdef __MHS__ import Prelude hiding (mapM, mapM_, sequence, sequence_, setField) -#else -import Prelude hiding (setField) -#endif #endif #ifdef __MHS__ import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) diff --git a/src/Miso/Native/FFI.hs b/src/Miso/Native/FFI.hs index e00e045e4..a3e189062 100644 --- a/src/Miso/Native/FFI.hs +++ b/src/Miso/Native/FFI.hs @@ -21,9 +21,7 @@ module Miso.Native.FFI ) where ---------------------------------------------------------------------------- #ifdef __MHS__ -#ifdef __MHS__ import Prelude hiding (mapM, mapM_, sequence, sequence_) -#endif import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) import Data.Foldable (forM_, mapM_, sequence_) import Data.Traversable (forM, mapM, sequence) diff --git a/src/Miso/Subscription/History.hs b/src/Miso/Subscription/History.hs index 78bd5184b..63f160a19 100644 --- a/src/Miso/Subscription/History.hs +++ b/src/Miso/Subscription/History.hs @@ -80,9 +80,7 @@ module Miso.Subscription.History ) where ----------------------------------------------------------------------------- #ifdef __MHS__ -#ifdef __MHS__ import Prelude hiding (mapM, mapM_, sequence, sequence_) -#endif import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) import Data.Foldable (forM_, mapM_, sequence_) import Data.Traversable (forM, mapM, sequence) diff --git a/src/Miso/Subscription/Window.hs b/src/Miso/Subscription/Window.hs index dbefbb1ef..7c0c506ea 100644 --- a/src/Miso/Subscription/Window.hs +++ b/src/Miso/Subscription/Window.hs @@ -74,9 +74,7 @@ module Miso.Subscription.Window ) where ----------------------------------------------------------------------------- #ifdef __MHS__ -#ifdef __MHS__ import Prelude hiding (mapM, mapM_, sequence, sequence_) -#endif import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) import Data.Foldable (forM_, mapM_, sequence_) import Data.Traversable (forM, mapM, sequence) diff --git a/src/Miso/Util/Lexer.hs b/src/Miso/Util/Lexer.hs index 63ae8d1fb..75a4c7ecb 100644 --- a/src/Miso/Util/Lexer.hs +++ b/src/Miso/Util/Lexer.hs @@ -101,9 +101,7 @@ module Miso.Util.Lexer ) where ---------------------------------------------------------------------------- #ifdef __MHS__ -#ifdef __MHS__ import Prelude hiding (mapM, mapM_, sequence, sequence_) -#endif import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence, sequence_) import Data.Foldable (forM_, mapM_, sequence_) import Data.Traversable (forM, mapM, sequence) From 2e21708847b648d98317d391f8fe7360ffdc0f7f Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 18:39:26 -0500 Subject: [PATCH 26/34] JSON: test __MHS__ rather than MHS, like the other modules --- src/Miso/JSON.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Miso/JSON.hs b/src/Miso/JSON.hs index 37d1df2a1..3d93567c5 100644 --- a/src/Miso/JSON.hs +++ b/src/Miso/JSON.hs @@ -1356,7 +1356,7 @@ foreign import javascript unsafe encodePretty_ffi :: JSVal -> Int -> IO MisoString #endif ----------------------------------------------------------------------------- -#if defined(WASM) || defined(MHS) +#if defined(WASM) || defined(__MHS__) #ifdef MISO_TEXT foreign import javascript unsafe "return JSON.stringify($1, null, $2);" @@ -1414,7 +1414,7 @@ foreign import javascript unsafe jsonStringify :: JSVal -> IO MisoString #endif ----------------------------------------------------------------------------- -#if defined(WASM) || defined(MHS) +#if defined(WASM) || defined(__MHS__) #ifdef MISO_TEXT foreign import javascript unsafe "return JSON.stringify($1);" @@ -1446,7 +1446,7 @@ foreign import javascript unsafe jsonParse :: MisoString -> IO JSVal #endif ----------------------------------------------------------------------------- -#if defined(WASM) || defined(MHS) +#if defined(WASM) || defined(__MHS__) #ifdef MISO_TEXT foreign import javascript unsafe "return JSON.parse($1);" @@ -1595,7 +1595,7 @@ fromJSVal_Value jsval_ = do toObject = mkObject #endif ----------------------------------------------------------------------------- -#if defined(WASM) || defined(MHS) +#if defined(WASM) || defined(__MHS__) fromJSVal_Value :: JSVal -> IO (Maybe Value) fromJSVal_Value jsval = do typeof jsval >>= \case @@ -1651,7 +1651,7 @@ foreign import javascript unsafe typeof :: JSVal -> IO Int #endif ----------------------------------------------------------------------------- -#if defined(WASM) || defined(MHS) +#if defined(WASM) || defined(__MHS__) foreign import javascript unsafe "return globalThis.miso.typeOf($1);" typeof :: JSVal -> IO Int @@ -1663,7 +1663,7 @@ foreign import javascript unsafe typeof :: JSVal -> IO Int #endif ----------------------------------------------------------------------------- -#if defined(WASM) || defined(MHS) +#if defined(WASM) || defined(__MHS__) -- | Convert a Miso JSON t'Value' to a raw JavaScript value via FFI. toJSVal_Value :: Value -> IO JSVal toJSVal_Value = \case From 821ff5a9e277f059742a91f9ff7ed9cca28caa91 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 18:39:26 -0500 Subject: [PATCH 27/34] Makefile.mhs: remove the unused MHS_VERSION --- Makefile.mhs | 2 -- 1 file changed, 2 deletions(-) diff --git a/Makefile.mhs b/Makefile.mhs index 7251403e6..5f17c2e3e 100644 --- a/Makefile.mhs +++ b/Makefile.mhs @@ -21,8 +21,6 @@ # Revisions are kept in step with nix/source.nix -- change them in both. ##################################################################### -MHS_VERSION := 0.16.6.0 - # MicroHs with the JSVal/JavaScript FFI and browser targets: dmjio/MicroHs, # branch rts-standalone. Upstream augustss/MicroHs will not work. MICROHS_URL := https://github.com/dmjio/MicroHs From a648d3fffbf3c1ac80a973f26a77b8bd85d6e757 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 20:31:02 -0500 Subject: [PATCH 28/34] Bump MicroHs to 35dfea07 Picks up the review fixes: freed callbacks, callback results and the GC, the snippet cache, throwTo from callbacks, JavaScript exceptions raised as their JSVal (no global slot), ASYNCIFY only for emcc, and Data.Text.chunksOf. Both playwright-mhs (browser) and playwright-mhs-js (browser_js) pass all 290 tests. --- Makefile.mhs | 2 +- nix/source.nix | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile.mhs b/Makefile.mhs index 5f17c2e3e..05ba98919 100644 --- a/Makefile.mhs +++ b/Makefile.mhs @@ -24,7 +24,7 @@ # MicroHs with the JSVal/JavaScript FFI and browser targets: dmjio/MicroHs, # branch rts-standalone. Upstream augustss/MicroHs will not work. MICROHS_URL := https://github.com/dmjio/MicroHs -MICROHS_REV := 05240a5cc9407b946a471fa0a8c039d7adbc319c +MICROHS_REV := 35dfea070a37f10943d887538875991c4b89951c GHC_COMPAT_URL := https://github.com/augustss/ghc-compat GHC_COMPAT_REV := e04bd70e4040d52cd1d319387bda7514000b58a0 diff --git a/nix/source.nix b/nix/source.nix index 55d9ce734..41366cb0c 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "05240a5cc9407b946a471fa0a8c039d7adbc319c"; - hash = "sha256-K6HfJAyPJ/rVUAyShBrRarHxuhe7mTLYGlMjAaYycys="; + rev = "35dfea070a37f10943d887538875991c4b89951c"; + hash = "sha256-bxeUmO/bVTVF293d53jMPmPS5/YUwiPYIVMxsa6MGDI="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; From b745b702ca6f392f8d5301b5a7132445050b1588 Mon Sep 17 00:00:00 2001 From: dmjio Date: Sat, 26 Sep 2026 23:41:30 -0500 Subject: [PATCH 29/34] Router: give Capture's symbol parameter its kind MicroHs infers 'sym :: Type' without the annotation and rejects 'Capture "slug" MisoString' with a kind error; GHC is unaffected. --- src/Miso/Router.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Miso/Router.hs b/src/Miso/Router.hs index 46e2e9e36..919aef843 100644 --- a/src/Miso/Router.hs +++ b/src/Miso/Router.hs @@ -179,7 +179,7 @@ import Miso.String (ToMisoString, FromMisoString, fromMisoStringEither import qualified Miso.String as MS ----------------------------------------------------------------------------- -- | Type used for representing capture variables -newtype Capture sym a = Capture a +newtype Capture (sym :: Symbol) a = Capture a deriving stock (Eq, Show) deriving newtype (ToMisoString, FromMisoString) ----------------------------------------------------------------------------- From 53e8157a3e162776e48d1fb17e9350f6e2124f2e Mon Sep 17 00:00:00 2001 From: dmjio Date: Sun, 27 Sep 2026 13:58:11 -0500 Subject: [PATCH 30/34] Bump MicroHs to 2e148dc6 (0.16.7.0, branch jsval) dmjio/MicroHs's rts-standalone branch was rebased onto upstream master and renamed to jsval. --- Makefile.mhs | 4 ++-- nix/mhs/default.nix | 2 +- nix/source.nix | 6 +++--- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Makefile.mhs b/Makefile.mhs index 05ba98919..ba10874cf 100644 --- a/Makefile.mhs +++ b/Makefile.mhs @@ -22,9 +22,9 @@ ##################################################################### # MicroHs with the JSVal/JavaScript FFI and browser targets: dmjio/MicroHs, -# branch rts-standalone. Upstream augustss/MicroHs will not work. +# branch jsval. Upstream augustss/MicroHs will not work. MICROHS_URL := https://github.com/dmjio/MicroHs -MICROHS_REV := 35dfea070a37f10943d887538875991c4b89951c +MICROHS_REV := 2e148dc6def6acc80b011def2a76b9d8d591a30b GHC_COMPAT_URL := https://github.com/augustss/ghc-compat GHC_COMPAT_REV := e04bd70e4040d52cd1d319387bda7514000b58a0 diff --git a/nix/mhs/default.nix b/nix/mhs/default.nix index 20aeb00d3..6850be826 100644 --- a/nix/mhs/default.nix +++ b/nix/mhs/default.nix @@ -8,7 +8,7 @@ self: super: let src = import ../source.nix super; - version = "0.16.6.0"; + version = "0.16.7.0"; # Package database of a derivation, as seen by mhs/mcabal. cabalDir = drv: "${drv}/lib/mcabal"; mhsDir = drv: "${cabalDir drv}/mhs-${version}"; diff --git a/nix/source.nix b/nix/source.nix index 41366cb0c..86d0482e7 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -71,13 +71,13 @@ in }; # MicroHs (mhs) with the JSVal / JavaScript FFI, browser targets and - # js-sources support (dmjio/MicroHs, branch rts-standalone), plus the + # js-sources support (dmjio/MicroHs, branch jsval), plus the # packages miso needs when built with mhs. See nix/mhs/default.nix. microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "35dfea070a37f10943d887538875991c4b89951c"; - hash = "sha256-bxeUmO/bVTVF293d53jMPmPS5/YUwiPYIVMxsa6MGDI="; + rev = "2e148dc6def6acc80b011def2a76b9d8d591a30b"; + hash = "sha256-mAXwUZaR5URmNK+JW25diO1rBXmcfesm6yRQ5nT1qrQ="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; From eadcf6d61b9d0b7e51cf58b4ffdfdf6b040a256c Mon Sep 17 00:00:00 2001 From: dmjio Date: Mon, 28 Sep 2026 13:34:49 -0500 Subject: [PATCH 31/34] Bump MicroHs to 37b3943d jsval was rebased onto upstream master 1d316428 and gained a CI fix: (##) lexes as the empty unboxed tuple again. --- Makefile.mhs | 2 +- nix/source.nix | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile.mhs b/Makefile.mhs index ba10874cf..cdae063ca 100644 --- a/Makefile.mhs +++ b/Makefile.mhs @@ -24,7 +24,7 @@ # MicroHs with the JSVal/JavaScript FFI and browser targets: dmjio/MicroHs, # branch jsval. Upstream augustss/MicroHs will not work. MICROHS_URL := https://github.com/dmjio/MicroHs -MICROHS_REV := 2e148dc6def6acc80b011def2a76b9d8d591a30b +MICROHS_REV := 37b3943dcdd8300c14b30859554b8042bdc1add7 GHC_COMPAT_URL := https://github.com/augustss/ghc-compat GHC_COMPAT_REV := e04bd70e4040d52cd1d319387bda7514000b58a0 diff --git a/nix/source.nix b/nix/source.nix index 86d0482e7..341db4ce4 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "2e148dc6def6acc80b011def2a76b9d8d591a30b"; - hash = "sha256-mAXwUZaR5URmNK+JW25diO1rBXmcfesm6yRQ5nT1qrQ="; + rev = "37b3943dcdd8300c14b30859554b8042bdc1add7"; + hash = "sha256-AEdd8VWXFu3vw1eXp2aYerbL0cgvhSYHDGd6sx13BIU="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; From 804c8867d5a227ec67c1547e16f8b88db15f2de0 Mon Sep 17 00:00:00 2001 From: dmjio Date: Wed, 30 Sep 2026 13:35:40 -0500 Subject: [PATCH 32/34] Bump MicroHs to cabf54b9 --- Makefile.mhs | 2 +- nix/source.nix | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile.mhs b/Makefile.mhs index cdae063ca..5c9694072 100644 --- a/Makefile.mhs +++ b/Makefile.mhs @@ -24,7 +24,7 @@ # MicroHs with the JSVal/JavaScript FFI and browser targets: dmjio/MicroHs, # branch jsval. Upstream augustss/MicroHs will not work. MICROHS_URL := https://github.com/dmjio/MicroHs -MICROHS_REV := 37b3943dcdd8300c14b30859554b8042bdc1add7 +MICROHS_REV := cabf54b99c0d3b842ca71dbd19f3de800a56420b GHC_COMPAT_URL := https://github.com/augustss/ghc-compat GHC_COMPAT_REV := e04bd70e4040d52cd1d319387bda7514000b58a0 diff --git a/nix/source.nix b/nix/source.nix index 341db4ce4..bb26140bc 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "37b3943dcdd8300c14b30859554b8042bdc1add7"; - hash = "sha256-AEdd8VWXFu3vw1eXp2aYerbL0cgvhSYHDGd6sx13BIU="; + rev = "cabf54b99c0d3b842ca71dbd19f3de800a56420b"; + hash = "sha256-QtKUDRnSq7D8q9eIoDwpYQy/Do/cvo7Wq+qFJVn/4ik="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss"; From 3930fa4d8fa182052fa085bf5674a48b9c9ca9cb Mon Sep 17 00:00:00 2001 From: "code@dmj.io" Date: Wed, 30 Sep 2026 17:23:47 -0500 Subject: [PATCH 33/34] sample-app: restore Main.hs from origin/master --- sample-app/Main.hs | 599 ++++----------------------------------------- 1 file changed, 53 insertions(+), 546 deletions(-) diff --git a/sample-app/Main.hs b/sample-app/Main.hs index e6a388337..374138ca4 100644 --- a/sample-app/Main.hs +++ b/sample-app/Main.hs @@ -1,567 +1,74 @@ ---------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} ---------------------------------------------------------------------------- module Main where ---------------------------------------------------------------------------- -import Control.Concurrent (threadDelay) -import Control.Monad (forever, when) -import Data.Foldable (toList) -import Data.Sequence (Seq, ViewL(..), ViewR(..)) -import qualified Data.Sequence as Seq -import Data.Set (Set) -import qualified Data.Set as Set ----------------------------------------------------------------------------- -import Miso hiding (Phase) -import Miso.CSS hiding (ms, background, Phase) +import Miso import qualified Miso.Html as H -import qualified Miso.Html.Property as HP -import qualified Miso.Svg as S -import qualified Miso.Svg.Property as SP import Miso.Lens -import Miso.Random (replicateRM) -import Miso.Reload +import Miso.JSON +import GHC.Generics (Generic) +---------------------------------------------------------------------------- +-- | Component model state +data Model + = Model + { _counter :: Int + } deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) +---------------------------------------------------------------------------- +counter :: Lens Model Int +counter = lens _counter $ \record field -> record { _counter = field } ---------------------------------------------------------------------------- - -gridSize :: Int -gridSize = 20 - -cellSize :: Int -cellSize = 24 - -boardPx :: Int -boardPx = gridSize * cellSize - -tickInterval :: Double -tickInterval = 120.0 - --- CSS transition slightly longer than the tick. Real tick spacing is --- tickInterval plus timer/render slop, so a transition of exactly --- tickInterval finishes early and leaves a variable per-tick freeze --- (visible jitter). Overshooting means a late tick interrupts a --- still-moving linear transition and motion stays continuous; a --- transition shorter than the tick stutters: move, pause, move. -segTransition :: Style -segTransition = transition ("transform " <> ms (round (tickInterval * 1.25) :: Int) <> "ms linear") - -data Dir = DUp | DDown | DLeft | DRight deriving (Show, Eq) - -data Phase = NotStarted | Playing | GameOver deriving (Show, Eq) - -data Model = Model - { _snake :: !(Seq (Int, Int)) - , _occupied :: !(Set (Int, Int)) - , _dir :: !Dir - , _queued :: ![Dir] - -- up to two pending turns; buffering two lets fast corner combos - -- (e.g. Up then Left within one tick) both register - , _food :: !(Int, Int) - , _score :: !Int - , _phase :: !Phase - , _prevLen :: !Int - -- snake length at start of last tick; suppresses CSS transition on newly-grown segments - , _prevSnake :: !(Seq (Int, Int)) - -- positions from last tick; per-segment jump detection for wall wraps - } deriving (Show, Eq) - -snake :: Lens Model (Seq (Int, Int)) -snake = lens _snake $ \r x -> r { _snake = x } - -occupied :: Lens Model (Set (Int, Int)) -occupied = lens _occupied $ \r x -> r { _occupied = x } - -dir :: Lens Model Dir -dir = lens _dir $ \r x -> r { _dir = x } - -queued :: Lens Model [Dir] -queued = lens _queued $ \r x -> r { _queued = x } - -food :: Lens Model (Int, Int) -food = lens _food $ \r x -> r { _food = x } - -score :: Lens Model Int -score = lens _score $ \r x -> r { _score = x } - -phase :: Lens Model Phase -phase = lens _phase $ \r x -> r { _phase = x } - -prevLen :: Lens Model Int -prevLen = lens _prevLen $ \r x -> r { _prevLen = x } - -prevSnake :: Lens Model (Seq (Int, Int)) -prevSnake = lens _prevSnake $ \r x -> r { _prevSnake = x } - +-- | Sum type for App events data Action - = Tick - | Turn Dir - | PlaceFood (Int, Int) - | NewGame - | NoOp - deriving (Show, Eq) - + = AddOne + | SubtractOne + | SayHelloWorld + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) +---------------------------------------------------------------------------- +-- | Entry point for a miso application main :: IO () #ifdef INTERACTIVE -main = reload Miso.pointerEvents app +main = live defaultEvents app #else -main = startApp Miso.pointerEvents app +main = startApp defaultEvents app #endif - +---------------------------------------------------------------------------- +-- | WASM export, required when compiling w/ the WASM backend. #ifdef WASM #ifndef INTERACTIVE foreign export javascript "hs_start" main :: IO () #endif #endif - -initSnake :: Seq (Int, Int) -initSnake = Seq.fromList [(10,10),(9,10),(8,10)] - -initOccupied :: Set (Int, Int) -initOccupied = Set.fromList [(10,10),(9,10),(8,10)] - -initFood :: (Int, Int) -initFood = (15,10) - -emptyModel :: Model -emptyModel = Model - { _snake = initSnake - , _occupied = initOccupied - , _dir = DRight - , _queued = [] - , _food = initFood - , _score = 0 - , _phase = NotStarted - , _prevLen = Seq.length initSnake - , _prevSnake = initSnake - } - +---------------------------------------------------------------------------- +-- | `component` takes as arguments the initial model, update function, view function app :: App Model Action -app = (component emptyModel updateModel viewModel) - { subs = - [ \sink _ -> forever (threadDelay (round (tickInterval * 1000)) >> sink Tick) - , windowSub "keydown" keycodeDecoder (\case - KeyCode 37 -> Turn DLeft - KeyCode 38 -> Turn DUp - KeyCode 39 -> Turn DRight - KeyCode 40 -> Turn DDown - KeyCode 78 -> NewGame - _ -> NoOp) - ] - } - -opposite :: Dir -> Dir -opposite DUp = DDown -opposite DDown = DUp -opposite DLeft = DRight -opposite DRight = DLeft - -step :: Dir -> (Int, Int) -> (Int, Int) -step DUp (x,y) = (x, (y - 1) `mod` gridSize) -step DDown (x,y) = (x, (y + 1) `mod` gridSize) -step DLeft (x,y) = ((x - 1) `mod` gridSize, y) -step DRight (x,y) = ((x + 1) `mod` gridSize, y) - -pickFood :: Set (Int, Int) -> IO (Int, Int) -pickFood occ = do - [rx, ry] <- replicateRM 2 - let x = floor (rx * fromIntegral gridSize) `mod` gridSize - y = floor (ry * fromIntegral gridSize) `mod` gridSize - if Set.member (x, y) occ then pickFood occ else pure (x, y) - -updateModel :: Action -> Effect parent props Model Action -updateModel = \case - NoOp -> pure () - - NewGame -> do - put emptyModel { _phase = Playing } - io $ pickFood initOccupied >>= pure . PlaceFood - - PlaceFood pos -> food .= pos - - Turn d -> do - m <- get - when (_phase m == NotStarted) (phase .= Playing) - -- validate against the last pending turn (or current dir), so a - -- buffered turn can't be followed by its own reversal - let effective = case _queued m of [] -> _dir m; qs -> last qs - when (d /= opposite effective && d /= effective && length (_queued m) < 2) $ - queued .= _queued m ++ [d] - - Tick -> do - m <- get - case _phase m of - NotStarted -> pure () - GameOver -> pure () - Playing -> do - let (d, rest) = case _queued m of - q:qs -> (q, qs) - [] -> (_dir m, []) - body = _snake m - occ = _occupied m - headPos = case Seq.viewl body of h :< _ -> h; _ -> (0,0) - newHead = step d headPos - self = Set.member newHead occ - dir .= d - queued .= rest - prevLen .= Seq.length body - prevSnake .= body - if self - then phase .= GameOver - else case Seq.viewr body of - EmptyR -> pure () - init' :> tailCell -> do - let ate = newHead == _food m - newBody | ate = newHead Seq.<| body - | otherwise = newHead Seq.<| init' - newOcc | ate = Set.insert newHead occ - | otherwise = Set.insert newHead (Set.delete tailCell occ) - snake .= newBody - occupied .= newOcc - when ate $ do - score += 1 - -- a full board has no free cell for pickFood to find - if Set.size newOcc == gridSize * gridSize - then phase .= GameOver - else io $ pickFood newOcc >>= pure . PlaceFood - +app = component emptyModel updateModel viewModel ---------------------------------------------------------------------------- --- View +-- | Empty application state +emptyModel :: Model +emptyModel = Model 0 +---------------------------------------------------------------------------- +-- | Updates model, optionally introduces side effects +updateModel :: Action -> Effect context props Model Action +updateModel = \case + AddOne -> counter += 1 + SubtractOne -> counter -= 1 + SayHelloWorld -> io_ (consoleLog "Hello world") ---------------------------------------------------------------------------- - -si :: Int -> MisoString -si = ms - -svgCoord :: Int -> Int -svgCoord n = n * cellSize + 1 - -viewModel :: Model -> View context props Model Action -viewModel m = - H.div_ - [ style_ - [ display "flex" - , flexDirection "column" - , alignItems "center" - , justifyContent "center" - , height "100dvh" - , margin "0" - , padding "0" - , backgroundColor (Hex "0d0d1a") - , fontFamily "'Segoe UI', system-ui, monospace" - , boxSizing "border-box" - , overflow "hidden" - ] - ] - - [ H.style_ [] - ( "html,body{margin:0;padding:0;overflow:hidden;overscroll-behavior:none;}" - <> ".board{touch-action:none;width:min(482px,calc(100vw - 16px));height:auto;}" - -- promote animating segments to compositor layers: transform - -- transitions then run off the main thread with no SVG repaint - <> ".seg{will-change:transform;}" - <> ".dpad{display:none;}" - <> "@media(pointer:coarse){.dpad{display:grid!important;}}" - <> "button{-webkit-tap-highlight-color:transparent;user-select:none;-webkit-user-select:none;}" - ) - , H.h1_ - [ style_ - [ margin "0 0 8px 0" - , fontWeight "700" - ] - ] - [ H.a_ - [ HP.href_ "https://github.com/haskell-miso/miso-snake" - , HP.target_ "_blank" - , style_ - [ color (Hex "4ade80") - , fontSize (px 36) - , letterSpacing "0.15em" - , textShadow "0 0 30px rgba(74,222,128,0.6), 0 0 60px rgba(74,222,128,0.2)" - , textDecoration "none" - ] - ] - [ text "\x1F35C miso snake" ] - ] - , H.div_ - [ style_ - [ display "flex" - , gap "32px" - , marginBottom "12px" - , color (Hex "94a3b8") - , fontSize (px 16) - , letterSpacing "0.05em" - ] - ] - [ H.span_ [ style_ [ color (Hex "4ade80"), fontWeight "600" ] ] - [ text ("SCORE " <> ms (_score m)) ] - ] - , board m - , dpad - , H.div_ - [ style_ - [ marginTop "12px" - , color (Hex "475569") - , fontSize (px 12) - , letterSpacing "0.1em" - ] - ] - [ text "ARROWS / D-PAD — MOVE N — NEW GAME" ] - ] - -board :: Model -> View context props Model Action -board m = - S.svg_ - [ HP.class_ "board" - , HP.width_ (si (boardPx + 2)) - , HP.height_ (si (boardPx + 2)) - , SP.viewBox_ ("0 0 " <> si (boardPx + 2) <> " " <> si (boardPx + 2)) - , style_ - [ borderRadius "10px" - , boxShadow "0 0 0 1px #1e2030, 0 0 40px rgba(74,222,128,0.12), 0 20px 60px rgba(0,0,0,0.6)" - ] - ] - ( defs - : background - : gridLines - : renderFood (_food m) - : renderSnake (_prevLen m) (_prevSnake m) (_snake m) - ++ [overlay m] - ) - -defs :: View context props Model Action -defs = - S.defs_ [] - [ S.filter_ - [ HP.id_ "glow", SP.x_ "-50%", SP.y_ "-50%", HP.width_ "200%", HP.height_ "200%" ] - [ S.feGaussianBlur_ [ SP.stdDeviation_ "3", SP.result_ "blur" ] - , S.feMerge_ [] - [ S.feMergeNode_ [ SP.in_' "blur" ] - , S.feMergeNode_ [ SP.in_' "SourceGraphic" ] - ] - ] - , S.filter_ - [ HP.id_ "foodglow", SP.x_ "-80%", SP.y_ "-80%", HP.width_ "260%", HP.height_ "260%" ] - [ S.feGaussianBlur_ [ SP.stdDeviation_ "5", SP.result_ "blur" ] - , S.feMerge_ [] - [ S.feMergeNode_ [ SP.in_' "blur" ] - , S.feMergeNode_ [ SP.in_' "SourceGraphic" ] - ] - ] - , S.radialGradient_ [ HP.id_ "headGrad", SP.cx_ "40%", SP.cy_ "35%", SP.r_ "60%" ] - [ S.stop_ [ SP.offset_ "0%", SP.stopColor_ "#86efac" ] - , S.stop_ [ SP.offset_ "100%", SP.stopColor_ "#16a34a" ] - ] - , S.radialGradient_ [ HP.id_ "bodyGrad", SP.cx_ "40%", SP.cy_ "35%", SP.r_ "60%" ] - [ S.stop_ [ SP.offset_ "0%", SP.stopColor_ "#4ade80" ] - , S.stop_ [ SP.offset_ "100%", SP.stopColor_ "#15803d" ] - ] - , S.radialGradient_ [ HP.id_ "foodGrad", SP.cx_ "35%", SP.cy_ "30%", SP.r_ "65%" ] - [ S.stop_ [ SP.offset_ "0%", SP.stopColor_ "#fb923c" ] - , S.stop_ [ SP.offset_ "100%", SP.stopColor_ "#c2410c" ] - ] - ] - -background :: View context props Model Action -background = - S.g_ [] - [ S.rect_ - [ SP.x_ "0", SP.y_ "0" - , HP.width_ (si (boardPx + 2)), HP.height_ (si (boardPx + 2)) - , SP.rx_ "10", SP.ry_ "10" - , SP.fill_ "#0d0d1a" - ] - , S.rect_ - [ SP.x_ "1", SP.y_ "1" - , HP.width_ (si boardPx), HP.height_ (si boardPx) - , SP.rx_ "6", SP.ry_ "6" - , SP.fill_ "#10101e" - ] - ] - --- all 38 grid lines as a single : one DOM node to convert, diff --- and paint per frame instead of 38 -gridLines :: View context props Model Action -gridLines = - S.path_ - [ SP.d_ (ms (concat ( - [ "M" ++ show (svgCoord col) ++ " 1V" ++ show (boardPx + 1) - | col <- [1..gridSize-1] ] ++ - [ "M1 " ++ show (svgCoord row) ++ "H" ++ show (boardPx + 1) - | row <- [1..gridSize-1] ]))) - , SP.fill_ "none" - , SP.stroke_ "#2a3f6f", SP.strokeWidth_ "1" - ] - -renderFood :: (Int, Int) -> View context props Model Action -renderFood (fx, fy) = - let cx = svgCoord fx + cellSize `div` 2 - cy = svgCoord fy + cellSize `div` 2 - r = cellSize `div` 2 - 3 - in S.g_ [ SP.filter_ "url(#foodglow)" ] - [ S.circle_ - [ SP.cx_ (si cx), SP.cy_ (si cy) - , SP.r_ (si r) - , SP.fill_ "url(#foodGrad)" - ] - , S.circle_ - [ SP.cx_ (si (cx - 2)), SP.cy_ (si (cy - 3)) - , SP.r_ "2" - , SP.fill_ "#fde68a" - , SP.opacity_ "0.7" - ] - ] - --- Head is rendered at list index 0 so Miso always patches the same DOM --- element for it — CSS transition fires correctly on every tick including --- eating. Body segments follow head-to-tail; the segment at index >= prevLen --- is newly grown and gets transition:none so it pops in at the old tail --- position instead of flying from the SVG origin. --- key_ is set on every element so Miso uses key-based reconciliation --- (requires ALL siblings to have keys; without key_ it falls back to --- position-based matching which also works but is less robust). --- Suppress transition for a segment whenever its position delta > 1, --- which happens on the tick a segment steps into a wrapped position. --- This covers the head on the wrap tick AND every body segment on the --- subsequent ticks as the wrapped position propagates down the snake. -renderSnake :: Int -> Seq (Int, Int) -> Seq (Int, Int) -> [View context props Model Action] -renderSnake pl prev curr = - let prevList = toList prev ++ repeat (0, 0) - in zipWith3 render [0..] prevList (toList curr) - where - jumped (px, py) (cx, cy) = abs (cx - px) > 1 || abs (cy - py) > 1 - render 0 p c = renderHead (jumped p c) c - render i p c = renderBody (i >= pl || jumped p c) i c - -renderHead :: Bool -> (Int, Int) -> View context props Model Action -renderHead suppress (hx, hy) = - let px = svgCoord hx - py = svgCoord hy - pad = 1 - sz = cellSize - 2 * pad - tx = "translate(" <> ms px <> "px," <> ms py <> "px)" - st | suppress = [ transform tx ] - | otherwise = [ transform tx, segTransition ] - in S.g_ - [ key_ (0 :: Int) - , HP.class_ "seg" - , style_ st - ] - -- glow as layered translucent rects instead of feGaussianBlur: - -- the blur filter forced a repaint on every frame of the - -- transition, causing visible hitching - [ S.rect_ - [ SP.x_ (si (pad - 4)), SP.y_ (si (pad - 4)) - , HP.width_ (si (sz + 8)), HP.height_ (si (sz + 8)) - , SP.rx_ "10", SP.ry_ "10" - , SP.fill_ "#4ade80", SP.opacity_ "0.15" - ] - , S.rect_ - [ SP.x_ (si (pad - 2)), SP.y_ (si (pad - 2)) - , HP.width_ (si (sz + 4)), HP.height_ (si (sz + 4)) - , SP.rx_ "8", SP.ry_ "8" - , SP.fill_ "#4ade80", SP.opacity_ "0.25" - ] - , S.rect_ - [ SP.x_ (si pad), SP.y_ (si pad) - , HP.width_ (si sz), HP.height_ (si sz) - , SP.rx_ "6", SP.ry_ "6" - , SP.fill_ "url(#headGrad)" - ] - ] - -renderBody :: Bool -> Int -> (Int, Int) -> View context props Model Action -renderBody isNew i (bx, by) = - let px = svgCoord bx - py = svgCoord by - pad = 2 - sz = cellSize - 2 * pad - tx = "translate(" <> ms px <> "px," <> ms py <> "px)" - st | isNew = [ transform tx ] - | otherwise = [ transform tx, segTransition ] - in S.g_ - [ key_ i - , HP.class_ "seg" - , style_ st - ] - [ S.rect_ - [ SP.x_ (si pad), SP.y_ (si pad) - , HP.width_ (si sz), HP.height_ (si sz) - , SP.rx_ "4", SP.ry_ "4" - , SP.fill_ "url(#bodyGrad)" - ] - ] - -overlay :: Model -> View context props Model Action -overlay m = case _phase m of - Playing -> S.g_ [] [] - NotStarted -> overlayBox "TAP TO BEGIN" "OR PRESS AN ARROW KEY" "#4ade80" (Turn DRight) - GameOver -> overlayBox "GAME OVER" "TAP OR PRESS N" "#f87171" NewGame - -overlayBox :: MisoString -> MisoString -> MisoString -> Action -> View context props Model Action -overlayBox title sub clr act = - S.g_ [ H.onPointerDown (const act), style_ [ cursor "pointer" ] ] - [ S.rect_ - [ SP.x_ "0", SP.y_ "0" - , HP.width_ (si (boardPx + 2)), HP.height_ (si (boardPx + 2)) - , SP.rx_ "10", SP.ry_ "10" - , SP.fill_ "rgba(10,10,20,0.82)" - ] - , S.text_ - [ SP.x_ (si ((boardPx + 2) `div` 2)) - , SP.y_ (si ((boardPx + 2) `div` 2 - 20)) - , SP.textAnchor_ "middle" - , SP.dominantBaseline_ "middle" - , SP.fill_ clr - , SP.fontSize_ "26" - , SP.fontWeight_ "700" - , SP.letterSpacing_ "4" - , SP.filter_ "url(#glow)" - ] [ text title ] - , S.text_ - [ SP.x_ (si ((boardPx + 2) `div` 2)) - , SP.y_ (si ((boardPx + 2) `div` 2 + 20)) - , SP.textAnchor_ "middle" - , SP.dominantBaseline_ "middle" - , SP.fill_ "#94a3b8" - , SP.fontSize_ "13" - , SP.letterSpacing_ "2" - ] [ text sub ] - ] - -dpad :: View context props Model Action -dpad = - H.div_ - [ HP.class_ "dpad" - , style_ - [ gridTemplateColumns "repeat(3, 56px)" - , gridTemplateRows "repeat(3, 56px)" - , gap "4px" - , marginTop "12px" - ] - ] - [ H.div_ [] [], btn DUp "\x25b2", H.div_ [] [] - , btn DLeft "\x25c4", H.div_ [] [], btn DRight "\x25ba" - , H.div_ [] [], btn DDown "\x25bc", H.div_ [] [] - ] - where - btn d lbl = - H.button_ - [ H.onPointerDown (const (Turn d)) - , style_ - [ width "100%" - , height "100%" - , borderRadius "10px" - , backgroundColor (RGBA 74 222 128 0.12) - , border "1px solid rgba(74,222,128,0.25)" - , color (Hex "4ade80") - , fontSize (px 20) - , cursor "pointer" - , display "flex" - , alignItems "center" - , justifyContent "center" - , padding "0" - , boxSizing "border-box" - ] - ] - [ text lbl ] +-- | Constructs a virtual DOM from a model +viewModel :: Model -> View () () Model Action +viewModel (Model x) = + vfrag + [ H.button_ [ H.onClick AddOne ] [ "+" ] + , text (ms x) + , H.button_ [ H.onClick SubtractOne ] [ "-" ] + ] ---------------------------------------------------------------------------- From 91fa9e576a925e22a35838f2a86b1fedf6698b1d Mon Sep 17 00:00:00 2001 From: "code@dmj.io" Date: Wed, 30 Sep 2026 18:18:11 -0500 Subject: [PATCH 34/34] Bump MicroHs to 9c398a27 --- Makefile.mhs | 2 +- nix/source.nix | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile.mhs b/Makefile.mhs index 5c9694072..c65e43e44 100644 --- a/Makefile.mhs +++ b/Makefile.mhs @@ -24,7 +24,7 @@ # MicroHs with the JSVal/JavaScript FFI and browser targets: dmjio/MicroHs, # branch jsval. Upstream augustss/MicroHs will not work. MICROHS_URL := https://github.com/dmjio/MicroHs -MICROHS_REV := cabf54b99c0d3b842ca71dbd19f3de800a56420b +MICROHS_REV := 9c398a2782df9089294ef191e76c3de99ea4fa9f GHC_COMPAT_URL := https://github.com/augustss/ghc-compat GHC_COMPAT_REV := e04bd70e4040d52cd1d319387bda7514000b58a0 diff --git a/nix/source.nix b/nix/source.nix index bb26140bc..11608df9b 100644 --- a/nix/source.nix +++ b/nix/source.nix @@ -76,8 +76,8 @@ in microhs = fetchFromGitHub { owner = "dmjio"; repo = "MicroHs"; - rev = "cabf54b99c0d3b842ca71dbd19f3de800a56420b"; - hash = "sha256-QtKUDRnSq7D8q9eIoDwpYQy/Do/cvo7Wq+qFJVn/4ik="; + rev = "9c398a2782df9089294ef191e76c3de99ea4fa9f"; + hash = "sha256-4j/HZphTSu+y8fmTl0eHjNGvxjH4MTkxc9clkYWSnvw="; }; mhs-ghc-compat = fetchFromGitHub { owner = "augustss";