diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index e9f667d7c..609bf3912 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -103,6 +103,15 @@ jobs: - name: (WASM) Miso integration tests run: nix-build -A playwright-wasm && ./result/bin/playwright + - 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 diff --git a/.gitignore b/.gitignore index a522e3e9c..cbd1fc7f4 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,11 @@ dist # nix result* +# MicroHs shell (nix develop .#mhs) +.mcabal/ +.emcache/ +dist-mcabal/ + # emacs *~ @@ -36,8 +41,12 @@ 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 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..c65e43e44 --- /dev/null +++ b/Makefile.mhs @@ -0,0 +1,190 @@ +##################################################################### +# 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. +##################################################################### + +# 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 := 9c398a2782df9089294ef191e76c3de99ea4fa9f + +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 mhs.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 diff --git a/default.nix b/default.nix index df224086f..52364ec25 100644 --- a/default.nix +++ b/default.nix @@ -192,6 +192,39 @@ rec { exit "$exit_code" ''; + # Same as playwright-wasm, but miso and the integration tests are built with + # 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} + export PATH="${pkgs.lib.makeBinPath [ pkgs.http-server pkgs.bun ]}:$PATH" + bun install playwright@${pkgs.playwright-driver.version} + 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" + ''; + 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 # miso-tests-aeson-wasm-bundle-ghc9141 above) -- unblocked by the nixpkgs 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/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..e9e67b4c9 --- /dev/null +++ b/ffi/mhs/Miso/DSL/FFI.hs @@ -0,0 +1,448 @@ +----------------------------------------------------------------------------- +{-# 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 'JSString' on this backend (or +-- 'Text' with MISO_TEXT) +-- (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 +#ifdef MISO_TEXT + , toString_Int + , toString_Double + , toString_Float + , toString_Word +#endif + , textFromJSString + , textToJSString + , JSException + ) where +----------------------------------------------------------------------------- +import Control.Monad +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 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. +#ifdef MISO_TEXT +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 @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 T.unpack (T.strip input) of + ('-' : rest) -> negate <$> unsigned rest + ('+' : rest) -> unsigned rest + s -> unsigned s + where + 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 +----------------------------------------------------------------------------- +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 +#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/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/miso.cabal b/miso.cabal index 9b5638725..b6865aa6b 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 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 @@ -307,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 @@ -315,10 +318,25 @@ library Miso.DSL.TH.File other-modules: Data.JSString + elif impl(mhs) + hs-source-dirs: + ffi/mhs + ffi/jsstring + other-modules: + Data.JSString + 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/nix/mhs/default.nix b/nix/mhs/default.nix new file mode 100644 index 000000000..6850be826 --- /dev/null +++ b/nix/mhs/default.nix @@ -0,0 +1,168 @@ +# 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.16.7.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..11608df9b 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" ".mcabal" ".emcache" "node_modules" "result" ] ++ excludedNames; in (!elem baseName excluded && ( @@ -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 jsval), plus the + # packages miso needs when built with mhs. See nix/mhs/default.nix. + microhs = fetchFromGitHub { + owner = "dmjio"; + repo = "MicroHs"; + rev = "9c398a2782df9089294ef191e76c3de99ea4fa9f"; + hash = "sha256-4j/HZphTSu+y8fmTl0eHjNGvxjH4MTkxc9clkYWSnvw="; + }; + 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"; + }; } diff --git a/sample-app/Makefile b/sample-app/Makefile index 63fa623e0..5e6713b93 100644 --- a/sample-app/Makefile +++ b/sample-app/Makefile @@ -54,3 +54,25 @@ 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 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) +MHS_FLAGS=-XCPP -DMHS -i../src -i../ffi/mhs -i../ffi/jsstring -js ../js/miso.js + +mhs: + mkdir -p 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/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 diff --git a/sample-app/static-mhs/index.html b/sample-app/static-mhs/index.html new file mode 100644 index 000000000..67261b348 --- /dev/null +++ b/sample-app/static-mhs/index.html @@ -0,0 +1,11 @@ + + + + + + sample-app (MicroHs) + + + + + 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..e130c235e 100644 --- a/src/Miso/CSS/Color.hs +++ b/src/Miso/CSS/Color.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} @@ -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..4014cbc7d 100644 --- a/src/Miso/Cookie.hs +++ b/src/Miso/Cookie.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# 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..050662a0c 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,24 @@ 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__ +import Prelude hiding (mapM, mapM_, sequence, sequence_, setField, (!!)) +#else import Prelude hiding ((!!)) +#endif ----------------------------------------------------------------------------- import Miso.DSL.FFI import Miso.JSON (Value, fromJSVal_Value, toJSVal_Value) @@ -189,12 +203,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. @@ -233,6 +250,7 @@ instance GToJSVal U1 where instance GToJSVal V1 where gToJSVal _ _ = pure () {-# INLINE gToJSVal #-} +#endif ----------------------------------------------------------------------------- instance ToJSVal Bool where toJSVal = toJSVal_Bool @@ -318,14 +336,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. @@ -365,6 +386,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 +806,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..d04120b29 100644 --- a/src/Miso/Data/Array.hs +++ b/src/Miso/Data/Array.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -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..d48216fa0 100644 --- a/src/Miso/Data/Map.hs +++ b/src/Miso/Data/Map.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# 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..76a242ce4 100644 --- a/src/Miso/Data/Set.hs +++ b/src/Miso/Data/Set.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# 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..320b2d8a7 100644 --- a/src/Miso/Event.hs +++ b/src/Miso/Event.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -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..fe1b222db 100644 --- a/src/Miso/Event/Types.hs +++ b/src/Miso/Event/Types.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} @@ -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..3d93567c5 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..0c15de53f 100644 --- a/src/Miso/Lens.hs +++ b/src/Miso/Lens.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -847,32 +848,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 +903,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 +920,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..139ffa2e6 100644 --- a/src/Miso/Lens/TH.hs +++ b/src/Miso/Lens/TH.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# 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..61efc9916 100644 --- a/src/Miso/Media.hs +++ b/src/Miso/Media.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- @@ -119,7 +120,16 @@ module Miso.Media , mediaEvents ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_, setField) +#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..a3e189062 100644 --- a/src/Miso/Native/FFI.hs +++ b/src/Miso/Native/FFI.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | @@ -19,7 +20,14 @@ module Miso.Native.FFI , enableDebugging ) where ---------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +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..3ea4c66fd 100644 --- a/src/Miso/Native/MainThread.hs +++ b/src/Miso/Native/MainThread.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} @@ -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..919aef843 100644 --- a/src/Miso/Router.hs +++ b/src/Miso/Router.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DerivingStrategies #-} @@ -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 (..)) @@ -163,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) ----------------------------------------------------------------------------- @@ -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..255499a09 100644 --- a/src/Miso/Subscription/Cookie.hs +++ b/src/Miso/Subscription/Cookie.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# 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..63f160a19 100644 --- a/src/Miso/Subscription/History.hs +++ b/src/Miso/Subscription/History.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | @@ -78,7 +79,14 @@ module Miso.Subscription.History , URI (..) ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +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/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) ---------------------------------------------------------------------------- diff --git a/src/Miso/Subscription/Window.hs b/src/Miso/Subscription/Window.hs index 39e9a07db..7c0c506ea 100644 --- a/src/Miso/Subscription/Window.hs +++ b/src/Miso/Subscription/Window.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- @@ -72,13 +73,20 @@ module Miso.Subscription.Window , Coord ) where ----------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +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/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 diff --git a/src/Miso/Util/Lexer.hs b/src/Miso/Util/Lexer.hs index b293d177e..75a4c7ecb 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 @@ -100,7 +100,14 @@ module Miso.Util.Lexer , withLocation ) where ---------------------------------------------------------------------------- +#ifdef __MHS__ +import Prelude hiding (mapM, mapM_, sequence, sequence_) +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/tests/app/Main.hs b/tests/app/Main.hs index 45e3d6e1a..80660ea34 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 @@ -690,6 +738,7 @@ main = withJS $ do `shouldBe` Right (JSON.object [("a",JSON.Bool True),("b",JSON.Number 1.1)]) 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" @@ -699,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) @@ -706,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 @@ -820,7 +871,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 } @@ -843,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) @@ -852,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 @@ -885,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\"") @@ -1001,7 +1055,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) @@ -1141,6 +1195,7 @@ main = withJS $ do it "Should use inline js" $ do (`shouldBe` 42) =<< liftIO (getAge (Person "larry" 42)) describe "Router tests" $ do +#ifndef __MHS__ it "should call fromRoute on Index" $ do fromRoute Index `shouldBe` [ IndexToken ] it "should call fromRoute on Home" $ do @@ -1165,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 @@ -1198,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` @@ -1706,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 @@ -1800,6 +1868,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 +1896,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 +1919,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..b359b24dd 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 else cpp-options: -DVANILLA