ghc-wasm-bindgen (empty) → 0.1.0.0
raw patch · 23 files changed
+1982/−0 lines, 23 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, directory, file-embed, filepath, ghc, ghc-paths, ghc-wasm-bindgen, process, text
Files
- CHANGELOG.md +15/−0
- LICENSE +21/−0
- README.md +123/−0
- app/Main.hs +84/−0
- ghc-wasm-bindgen.cabal +84/−0
- runtime-hs/GhcWasmBindgen/Runtime.hs +76/−0
- runtime-js/ghc_wasm_bindgen_internal.d.ts +94/−0
- runtime-js/ghc_wasm_bindgen_internal.js +197/−0
- runtime-js/ghc_wasm_bindgen_runtime.d.ts +5/−0
- runtime-js/ghc_wasm_bindgen_runtime.js +3/−0
- runtime-js/ghc_wasm_jsffi.d.ts +4/−0
- src/GhcWasmBindgen.hs +293/−0
- src/GhcWasmBindgen/EmitHaskell.hs +80/−0
- src/GhcWasmBindgen/EmitJavaScript.hs +343/−0
- src/GhcWasmBindgen/Inspect.hs +326/−0
- src/GhcWasmBindgen/Model.hs +177/−0
- test/Errors.hs +24/−0
- test/Main.hs +17/−0
- test/errors/HigherOrder.hs +3/−0
- test/errors/Operator.hs +3/−0
- test/errors/Polymorphic.hs +3/−0
- test/errors/Unexported.hs +4/−0
- test/errors/UsesIO.hs +3/−0
+ CHANGELOG.md view
@@ -0,0 +1,15 @@+# Changelog++## 0.1.0.0++First release.++- `build`: builds a cabal project into an npm package (JS bindings,+ TypeScript declarations, `.wasm`, runtime and `package.json`).+- `generate`: writes the Haskell and JS bindings for plain source files.+- Standard types: numbers (including `Integer`/`Natural` as `bigint`), `Bool`,+ `Char`, `String`, `Text`, `Day`, `UTCTime`, `Maybe`, `Either`, tuples, lists,+ `Vector`, `NonEmpty`, `Set`/`HashSet`/`IntSet` and `Map`/`HashMap`/`IntMap`.+- User data types: records, positional constructors and enums.+- Arguments are validated before reaching Haskell; Haskell exceptions become+ `HaskellError` without breaking the module.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Joaquín Rossi++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,123 @@+# ghc-wasm-bindgen++Generates JavaScript/TypeScript bindings for a pure Haskell module compiled+with GHC's WASM backend.++```haskell+module ShapeWasm (Shape (..), area, scale, largest) where+import Shape+```++```ts+import { area, Circle, largest, Rect, scale } from "shape";+import { init } from "shape/runtime";++await init(wasmUrl);+area(Rect({ width: 3, height: 4 })); // 12+scale(2, Circle(1)); // { $tag: "Circle", contents: 2 }+largest([]); // null+area(Circle("x")); // TypeScript error+```++See [`example/`](example/) for a complete project.++## Types++| Haskell | TypeScript |+| ----------------------------------------------- | ----------------------------- |+| `Double`, `Float` | `number` |+| `Int`, `Word`, `Int8`…`Int64`, `Word8`…`Word64` | `number` |+| `Integer`, `Natural` | `bigint` |+| `Bool` | `boolean` |+| `Char`, `String`, `Text` | `string` |+| `Day` | `string` (YYYY-MM-DD) |+| `UTCTime` | `Date` |+| `Maybe a` | `a \| null` |+| `Either e a` | `{ Left: e } \| { Right: a }` |+| `(a, b)` | `[a, b]` |+| `[a]`, `Vector a` | `a[]` |+| `NonEmpty a` | `[a, ...a[]]` |+| `Set a`, `HashSet a`, `IntSet` | `Set<a>` |+| `Map k v`, `HashMap k v`, `IntMap v` | `Map<k, v>` |++Your own `data` and `newtype` declarations:++| Constructors | TypeScript |+| ------------------------- | ---------------------------- |+| with record fields | `{ $tag: "C"; field: … }` |+| positional | `{ $tag: "C"; contents: … }` |+| all without fields (enum) | `"A" \| "B"` |++Constructors are exported as functions: `Rect({ width: 3, height: 4 })` for+records, `Node(left, 3, right)` for positional ones, and constants like `Leaf`+for nullary ones. Names that are not valid in JS get a trailing `_`+(`delete` → `delete_`).++Notes:++- `Int` and `Word` are 32 bits on wasm32.+- Map keys can be strings, numbers, `Bool`, `Char`, dates or your own types.+ `Map` and `Set` compare keys by reference.+- `UTCTime` keeps millisecond precision.+- Every type the API uses must be exported with all its constructors.+- Not supported yet: `IO`, polymorphic functions, functions as arguments,+ operators, types with parameters and GADTs.++## Errors++- An argument that does not fit its type (an out-of-range integer, a `Char`+ that is not one code point, an unknown constructor, …) throws a `TypeError`+ before reaching Haskell.+- An exception in Haskell throws a `HaskellError`.++Either way, the module keeps working.++## Usage++### `build`: cabal projects++From the cabal project that contains the module:++```sh+ghc-wasm-bindgen build src/ShapeWasm.hs --name shape --out pkg+```++The module must be exposed by a library, in the same package as the code it+wraps or in one that depends on it. This writes the npm package `pkg/`+(`shape.js`, `shape.d.ts`, `shape.wasm`, the runtime and `package.json`).+Depend on it like any other package and import `shape`, `shape/runtime`+(`init`, `HaskellError`) and `shape/shape.wasm`.++### `generate`: plain source files++```sh+ghc-wasm-bindgen generate api/ShapeWasm.hs -i lib --name shape --hs-out gen --js-out out+```++This writes the Haskell bindings and runtime to `gen/`, and the JS bindings+and runtime to `out/`. Compiling is up to you:++```sh+wasm32-wasi-cabal install --lib aeson text --package-env . # once+wasm32-wasi-ghc -package ghc-experimental -igen -ilib -iapi gen/ShapeWasmBindings.hs \+ -no-hs-main -optl-mexec-model=reactor -outputdir build -o shape.wasm+"$(wasm32-wasi-ghc --print-libdir)"/post-link.mjs -i shape.wasm -o out/ghc_wasm_jsffi.js+wasm-opt -Oz shape.wasm -o out/shape.wasm+```++## Installation++```sh+cabal install ghc-wasm-bindgen+```++Requirements:++- GHC 9.10 and cabal.+- The WASM toolchain from+ [ghc-wasm-meta](https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta) on+ `PATH` (tested with GHC 9.14):++ ```sh+ curl https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta/-/raw/master/bootstrap.sh | FLAVOUR=9.14 sh+ ```
+ app/Main.hs view
@@ -0,0 +1,84 @@+module Main (main) where++import Control.Monad (forM_)+import Data.Char (isAlphaNum)+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++import GhcWasmBindgen++usage :: String+usage =+ unlines+ [ "usage:"+ , " ghc-wasm-bindgen build MODULE.hs --name NAME --out DIR"+ , " ghc-wasm-bindgen generate MODULE.hs --name NAME --hs-out DIR --js-out DIR [-i DIR]..."+ , ""+ , "build From the cabal project that contains MODULE.hs, builds an npm package:"+ , " NAME.js, NAME.d.ts, NAME.wasm, the runtime and a package.json."+ , " Needs cabal, and wasm32-wasi-cabal, wasm32-wasi-ghc and wasm-opt"+ , " (ghc-wasm-meta) on PATH."+ , "generate For plain source files: writes NameWasmBindings.hs and the Haskell"+ , " runtime to --hs-out, NAME.js, NAME.d.ts and the JS runtime to --js-out."+ , " Compiling them is up to you."+ , ""+ , " MODULE.hs module whose export list is the API (e.g. src/ShapeWasm.hs)"+ , " --name NAME package and file name (e.g. shape)"+ , " --out DIR output directory of the package (e.g. pkg)"+ , " -i DIR import directory for the modules MODULE.hs imports"+ , " (MODULE.hs's own source root is added)"+ ]++data Command = Build Options | Generate GenerateOptions++parse :: [String] -> Either String Command+parse = \case+ "build" : rest -> Build <$> go rest (Options "" "" "")+ (\f o -> o {optModule = f}) optModule+ (\n o -> o {optName = n})+ [("--out", \d o -> o {optOut = d})]+ "generate" : rest -> Generate <$> go rest (GenerateOptions "" "" "" "" [])+ (\f o -> o {genModule = f}) genModule+ (\n o -> o {genName = n})+ [ ("--hs-out", \d o -> o {genHsOut = d})+ , ("--js-out", \d o -> o {genJsOut = d})+ , ("-i", \d o -> o {genImportDirs = genImportDirs o ++ [d]})+ ]+ _ -> Left "expected a command: build or generate"+ where+ go args o setModule getModule setName flags = case args of+ [] -> Right o+ "--name" : n : rest -> name n >>= \n' -> go rest (setName n' o) setModule getModule setName flags+ flag : value : rest | Just set <- lookup flag flags -> go rest (set value o) setModule getModule setName flags+ flag@('-' : _) : _ -> Left ("unknown option " ++ flag)+ f : rest+ | null (getModule o) -> go rest (setModule f o) setModule getModule setName flags+ | otherwise -> Left ("unexpected argument " ++ f)+ name n+ | n `elem` ["ghc_wasm_bindgen_runtime", "ghc_wasm_bindgen_internal", "ghc_wasm_jsffi"] = Left ("--name " ++ n ++ " would overwrite the runtime files")+ | null n || not (all (\c -> isAlphaNum c || c `elem` ("_-" :: String)) n) = Left ("--name must be letters, digits, _ or -: " ++ show n)+ | otherwise = Right n++main :: IO ()+main = do+ args <- getArgs+ if args `elem` [["-h"], ["--help"]]+ then putStr usage+ else case parse args of+ Left e -> hPutStrLn stderr (e ++ "\n\n" ++ usage) >> exitFailure+ Right (Build o)+ | any null [optModule o, optName o, optOut o] -> hPutStrLn stderr usage >> exitFailure+ | otherwise -> report (optModule o) (build o) (\out -> ["ghc-wasm-bindgen: built " ++ out])+ Right (Generate o)+ | any null [genModule o, genName o, genHsOut o, genJsOut o] -> hPutStrLn stderr usage >> exitFailure+ | otherwise -> report (genModule o) (generate o) (map ("wrote " ++))++report :: FilePath -> IO (Either [String] a) -> (a -> [String]) -> IO ()+report file act ok =+ act >>= \case+ Right a -> mapM_ putStrLn (ok a)+ Left errs -> do+ hPutStrLn stderr ("ghc-wasm-bindgen: cannot process " ++ file ++ ":")+ forM_ errs (hPutStrLn stderr . (" - " ++))+ exitFailure
+ ghc-wasm-bindgen.cabal view
@@ -0,0 +1,84 @@+cabal-version: 3.0+name: ghc-wasm-bindgen+version: 0.1.0.0+synopsis: JavaScript/TypeScript bindings for GHC's WASM backend+description:+ Generates JavaScript and TypeScript bindings for a pure Haskell module+ compiled with GHC's WebAssembly backend. The module's export list is the+ API: functions become typed JS functions, and data types become+ TypeScript types with constructors.++ @ghc-wasm-bindgen build@ builds a cabal project into an npm package (JS+ bindings, TypeScript declarations, the .wasm and a small runtime).+ @ghc-wasm-bindgen generate@ only writes the bindings, for plain source+ files compiled by hand.++ See the README for supported types and usage.+category: Web, WebAssembly, JavaScript, Development+homepage: https://github.com/joaquin-rossi/ghc-wasm-bindgen+bug-reports: https://github.com/joaquin-rossi/ghc-wasm-bindgen/issues+license: MIT+license-file: LICENSE+author: Joaquín Rossi+maintainer: joaquin@joaquinrossi.net+copyright: 2026 Joaquín Rossi+build-type: Simple+tested-with: GHC == 9.10.3+extra-doc-files:+ README.md+ CHANGELOG.md+extra-source-files:+ runtime-js/ghc_wasm_bindgen_runtime.js+ runtime-js/ghc_wasm_bindgen_runtime.d.ts+ runtime-js/ghc_wasm_bindgen_internal.js+ runtime-js/ghc_wasm_bindgen_internal.d.ts+ runtime-js/ghc_wasm_jsffi.d.ts+ runtime-hs/GhcWasmBindgen/Runtime.hs+ test/errors/*.hs++source-repository head+ type: git+ location: https://github.com/joaquin-rossi/ghc-wasm-bindgen.git++common shared+ default-language: GHC2021+ default-extensions: LambdaCase, OverloadedStrings+ ghc-options: -Wall+ build-depends:+ base >=4.20 && <4.21,+ bytestring >=0.11 && <0.13,+ text >=2.0 && <2.2++library+ import: shared+ hs-source-dirs: src+ exposed-modules:+ GhcWasmBindgen+ GhcWasmBindgen.Model+ GhcWasmBindgen.Inspect+ GhcWasmBindgen.EmitHaskell+ GhcWasmBindgen.EmitJavaScript+ build-depends:+ -- The GHC that typechecks the user's module is the one this tool is+ -- built with (ghc-paths); only Inspect imports it.+ ghc ==9.10.*,+ ghc-paths >=0.1.0.12 && <0.2,+ containers >=0.6 && <0.8,+ directory >=1.3.8 && <1.4,+ filepath >=1.4.100 && <1.6,+ file-embed >=0.0.15 && <0.1,+ process >=1.6.17 && <1.7++executable ghc-wasm-bindgen+ import: shared+ hs-source-dirs: app+ main-is: Main.hs+ build-depends: ghc-wasm-bindgen++test-suite tests+ import: shared+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: Errors+ build-depends: ghc-wasm-bindgen
+ runtime-hs/GhcWasmBindgen/Runtime.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE UndecidableInstances #-}++-- | Imported by the generated Haskell bindings. ADTs cross as JSON encoded with+-- 'options'; EmitJavaScript mirrors these options.+module GhcWasmBindgen.Runtime+ ( Bindgen (..)+ , Generic+ , ToJSON+ , FromJSON+ , ToJSONKey+ , FromJSONKey+ , JSString (..)+ , fromJSString+ , toJSString+ , fromJSText+ , toJSText+ , fromJS+ , toJS+ , Fallback+ , guarded+ ) where++import Control.Exception (SomeException, catch, displayException, evaluate)+import Data.Aeson+import Data.Aeson.Text (encodeToLazyText)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import GHC.Generics (Generic, Rep)+import GHC.Wasm.Prim (JSString (..), fromJSString, toJSString)++-- | The tag key is @$tag@: it cannot be a Haskell field name, so it never+-- clashes with a record field.+options :: Options+options = defaultOptions {sumEncoding = TaggedObject "$tag" "contents", tagSingleConstructors = True}++-- | @deriving via Bindgen T instance ToJSON T@ gives @T@ instances using 'options'.+newtype Bindgen a = Bindgen a++instance (Generic a, GToJSON' Value Zero (Rep a), GToJSON' Encoding Zero (Rep a)) => ToJSON (Bindgen a) where+ toJSON (Bindgen a) = genericToJSON options a+ toEncoding (Bindgen a) = genericToEncoding options a++instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (Bindgen a) where+ parseJSON = fmap Bindgen . genericParseJSON options++toJS :: ToJSON a => a -> JSString+toJS = toJSString . TL.unpack . encodeToLazyText++fromJS :: FromJSON a => JSString -> a+fromJS = either errorWithoutStackTrace id . eitherDecodeStrictText . fromJSText++fromJSText :: JSString -> Text+fromJSText = T.pack . fromJSString++toJSText :: Text -> JSString+toJSText = toJSString . T.unpack++-- | An uncaught exception in a sync export kills the RTS, so every export+-- runs through here. The message goes to a slot that+-- ghc_wasm_bindgen_internal.js checks after each call, and JS gets a+-- placeholder it discards. Results are primitives or JSStrings, so WHNF+-- forces everything.+guarded :: Fallback a => a -> IO a+guarded x = evaluate x `catch` \(e :: SomeException) -> fallback <$ setError (toJSString (displayException e))++foreign import javascript unsafe "__exports.__ghcWasmBindgenError = $1"+ setError :: JSString -> IO ()++class Fallback a where+ fallback :: a++instance Fallback Double where fallback = 0+instance Fallback Int where fallback = 0+instance Fallback Bool where fallback = False+instance Fallback JSString where fallback = toJSString ""
+ runtime-js/ghc_wasm_bindgen_internal.d.ts view
@@ -0,0 +1,94 @@+// ghc-wasm-bindgen runtime internals, imported by the generated bindings.++import type { Either } from "./ghc_wasm_bindgen_runtime";++/** Instantiates the .wasm module; must resolve before any binding is called. */+export function init(source: string | URL | BufferSource): Promise<void>;++/** A Haskell exception raised during a call. */+export class HaskellError extends Error {}++export function call(fn: string, ...args: unknown[]): any;++/** Opaque transfer representation. */+export type Value = { readonly __value: unique symbol };++export function pack(v: Value): string;+export function unpack(s: string): Value;+export function unpackBool(x: number): boolean;++/** Throws a TypeError for a value that is not a constructor of `type`. */+export function invalid(type: string, v: unknown): never;++// Standard types. Encoders throw a TypeError for invalid input.++export function encodeDouble(x: number): Value;+export function encodeFloat(x: number): Value;+/** Int and Word are 32 bits on wasm32. */+export function encodeInt(x: number): Value;+export function encodeWord(x: number): Value;+export function encodeInt8(x: number): Value;+export function encodeInt16(x: number): Value;+export function encodeInt32(x: number): Value;+/** Must be a safe integer. */+export function encodeInt64(x: number): Value;+export function encodeWord8(x: number): Value;+export function encodeWord16(x: number): Value;+export function encodeWord32(x: number): Value;+/** Must be a safe integer. */+export function encodeWord64(x: number): Value;+export function decodeNumber(v: Value | string): number;++export function encodeInteger(x: bigint): Value;+export function encodeNatural(x: bigint): Value;+export function decodeInteger(v: Value | string): bigint;++export function encodeBool(x: boolean): Value;+export function decodeBool(v: Value | string): boolean;++export function encodeString(x: string): Value;+/** Exactly one code point. */+export function encodeChar(x: string): Value;+export function decodeString(v: Value | string): string;++/** `YYYY-MM-DD`. */+export function encodeDay(x: string): Value;+export function encodeUTCTime(x: Date): Value;+export function decodeUTCTime(v: Value | string): Date;++export function encodeList<T>(xs: T[], f: (x: T) => Value): Value;+export function decodeList<T>(v: Value, f: (v: Value) => T): T[];++export function encodeNonEmpty<T>(xs: [T, ...T[]], f: (x: T) => Value): Value;++export function encodeSet<T>(xs: Set<T>, f: (x: T) => Value): Value;+export function decodeSet<T>(v: Value, f: (v: Value) => T): Set<T>;++/** Maps whose keys aeson writes as object keys (strings, numbers, Bool, Char, dates). */+export function encodeTextKeyMap<K, V>(m: Map<K, V>, key: (k: K) => Value, value: (x: V) => Value): Value;+export function decodeTextKeyMap<K, V>(v: Value, key: (k: string) => K, value: (v: Value) => V): Map<K, V>;++/** Maps written as arrays of pairs (any other key type, and IntMap). */+export function encodePairMap<K, V>(m: Map<K, V>, key: (k: K) => Value, value: (x: V) => Value): Value;+export function decodePairMap<K, V>(v: Value, key: (v: Value) => K, value: (v: Value) => V): Map<K, V>;++export function encodeMaybe<T>(x: T | null, f: (x: T) => Value): Value;+export function decodeMaybe<T>(v: Value, f: (v: Value) => T): T | null;++export function encodeEither<E, A>(x: Either<E, A>, left: (e: E) => Value, right: (a: A) => Value): Value;+export function decodeEither<E, A>(v: Value, left: (v: Value) => E, right: (v: Value) => A): Either<E, A>;++export function encodeTuple(xs: unknown[], fs: ((x: any) => Value)[]): Value;+export function decodeTuple(v: Value, fs: ((v: Value) => unknown)[]): any;++// User data types++export function encodeRecord(tag: string, fields: Record<string, Value>): Value;+export function encodePositional(tag: string, args: Value[]): Value;+/** For types whose constructors are all nullary. */+export function encodeEnum(tag: string): Value;++export function decodeTag(v: Value): unknown;+export function decodeField(v: Value, name: string): Value;+/** Field `i` of a positional constructor with `n` fields. */+export function decodeArg(v: Value, i: number, n: number): Value;
+ runtime-js/ghc_wasm_bindgen_internal.js view
@@ -0,0 +1,197 @@+// ghc-wasm-bindgen runtime internals, imported by the generated bindings.++import jsffiImports from "./ghc_wasm_jsffi.js";++let wasm;+let ready;++export function init(source) {+ return (ready ??= load(source));+}++async function load(source) {+ if (typeof source === "string" || source instanceof URL) {+ const res = await fetch(source);+ if (!res.ok) throw new Error(`ghc-wasm-bindgen: fetching ${source} failed (${res.status})`);+ source = await res.arrayBuffer();+ }+ // jsffiImports needs the exports, which exist only after instantiation.+ const knot = {};+ const { instance } = await WebAssembly.instantiate(source, {+ ghc_wasm_jsffi: jsffiImports(knot),+ wasi_snapshot_preview1: wasi(knot),+ });+ Object.assign(knot, instance.exports);+ knot._initialize();+ wasm = knot;+}++// WASI subset the RTS uses for pure code; other calls return ENOSYS.+function wasi(exports) {+ const view = () => new DataView(exports.memory.buffer);+ const noArgs = (count, size) => {+ view().setUint32(count, 0, true);+ view().setUint32(size, 0, true);+ return 0;+ };+ const calls = {+ args_sizes_get: noArgs,+ environ_sizes_get: noArgs,+ args_get: () => 0,+ environ_get: () => 0,+ clock_time_get: (clock, _precision, out) => {+ const ms = clock === 0 ? Date.now() : performance.now();+ view().setBigUint64(out, BigInt(Math.round(ms * 1e6)), true);+ return 0;+ },+ fd_write: (fd, iovs, count, written) => {+ const v = view();+ let text = "";+ let total = 0;+ for (let i = 0; i < count; i++) {+ const ptr = v.getUint32(iovs + 8 * i, true);+ const len = v.getUint32(iovs + 8 * i + 4, true);+ text += new TextDecoder().decode(new Uint8Array(exports.memory.buffer, ptr, len));+ total += len;+ }+ v.setUint32(written, total, true);+ (fd === 2 ? console.warn : console.log)(text.replace(/\n$/, ""));+ return 0;+ },+ proc_exit: (code) => {+ throw new Error(`ghc-wasm-bindgen: the Haskell runtime exited (code ${code})`);+ },+ };+ const ENOSYS = 52;+ return new Proxy(calls, { get: (target, name) => target[name] ?? (() => ENOSYS) });+}++export class HaskellError extends Error {+ name = "HaskellError";+}++// __ghcWasmBindgenError is set by GhcWasmBindgen.Runtime.guarded.+export function call(fn, ...args) {+ if (!wasm) throw new Error("ghc-wasm-bindgen: await init() before calling the API");+ const result = wasm[fn](...args);+ const err = wasm.__ghcWasmBindgenError;+ if (err !== undefined) {+ wasm.__ghcWasmBindgenError = undefined;+ throw new HaskellError(err);+ }+ return result;+}++// Values: aeson JSON, with the options in GhcWasmBindgen.Runtime. Encoders+// check their input; decoders trust what Haskell returns.++// bigints are written as JSON numbers, and integers beyond 2^53 are read as+// bigints, so Integer and Natural keep their precision.+export function pack(v) {+ const tag = marker();+ const json = JSON.stringify(v, (_, x) => (typeof x === "bigint" ? tag + x : x));+ return json.replace(new RegExp(`"\\\\u0000${tag.slice(1)}(-?\\d+)"`, "g"), "$1");+}++export function unpack(s) {+ const tag = marker();+ const text = s.replace(/"(?:\\.|[^"\\])*"|-?\d+(?:\.\d+)?(?:[eE][+-]?\d+)?/g, (token) =>+ /^-?\d+$/.test(token) && !Number.isSafeInteger(Number(token)) ? JSON.stringify(tag + token) : token,+ );+ return JSON.parse(text, (_, x) => (typeof x === "string" && x.startsWith(tag) ? BigInt(x.slice(tag.length)) : x));+}++const marker = () => `\u0000${Math.random().toString(36).slice(2)}:`;++export const unpackBool = (x) => x !== 0; // JSFFI returns Bool as 0/1++export function invalid(type, v) {+ let shown;+ try {+ shown = JSON.stringify(v, (_, x) => (typeof x === "bigint" ? `${x}n` : x));+ } catch {+ shown = String(v);+ }+ throw new TypeError(`ghc-wasm-bindgen: not a valid ${type}: ${shown}`);+}++const check = (type, ok) => (x) => (ok(x) ? x : invalid(type, x));+const integral = (type, min, max) => check(type, (x) => Number.isInteger(x) && x >= min && x <= max);++// Numbers. Int and Word are 32 bits on wasm32; 64-bit types must be safe integers.+export const encodeDouble = check("Double", (x) => typeof x === "number");+export const encodeFloat = check("Float", (x) => typeof x === "number");+export const encodeInt = integral("Int", -(2 ** 31), 2 ** 31 - 1);+export const encodeWord = integral("Word", 0, 2 ** 32 - 1);+export const encodeInt8 = integral("Int8", -(2 ** 7), 2 ** 7 - 1);+export const encodeInt16 = integral("Int16", -(2 ** 15), 2 ** 15 - 1);+export const encodeInt32 = integral("Int32", -(2 ** 31), 2 ** 31 - 1);+export const encodeInt64 = integral("Int64", Number.MIN_SAFE_INTEGER, Number.MAX_SAFE_INTEGER);+export const encodeWord8 = integral("Word8", 0, 2 ** 8 - 1);+export const encodeWord16 = integral("Word16", 0, 2 ** 16 - 1);+export const encodeWord32 = integral("Word32", 0, 2 ** 32 - 1);+export const encodeWord64 = integral("Word64", 0, Number.MAX_SAFE_INTEGER);+export const decodeNumber = (v) => Number(v);++export const encodeInteger = check("Integer", (x) => typeof x === "bigint");+export const encodeNatural = check("Natural", (x) => typeof x === "bigint" && x >= 0n);+export const decodeInteger = (v) => BigInt(v);++export const encodeBool = check("Bool", (x) => typeof x === "boolean");+export const decodeBool = (v) => v === true || v === "true";++export const encodeString = check("String", (x) => typeof x === "string");+export const encodeChar = check("Char", (x) => typeof x === "string" && [...x].length === 1);+export const decodeString = (v) => v;++export const encodeDay = check("Day", (x) => typeof x === "string" && /^-?\d{4,}-\d{2}-\d{2}$/.test(x));+export const encodeUTCTime = (x) =>+ x instanceof Date && !Number.isNaN(x.getTime()) ? x.toISOString() : invalid("UTCTime", x);+export const decodeUTCTime = (v) => new Date(v);++// Containers.+export const encodeList = (xs, f) => (Array.isArray(xs) ? xs.map((x) => f(x)) : invalid("list", xs));+export const decodeList = (v, f) => v.map((x) => f(x));++export const encodeNonEmpty = (xs, f) =>+ Array.isArray(xs) && xs.length > 0 ? xs.map((x) => f(x)) : invalid("NonEmpty", xs);++export const encodeSet = (xs, f) => (xs instanceof Set ? [...xs].map((x) => f(x)) : invalid("Set", xs));+export const decodeSet = (v, f) => new Set(v.map((x) => f(x)));++// Maps with string, number, Bool, Char or date keys are objects; any other+// key type makes them arrays of pairs.+export const encodeTextKeyMap = (m, key, value) =>+ m instanceof Map+ ? Object.fromEntries([...m].map(([k, x]) => [String(key(k)), value(x)]))+ : invalid("Map", m);+export const decodeTextKeyMap = (v, key, value) => new Map(Object.entries(v).map(([k, x]) => [key(k), value(x)]));++export const encodePairMap = (m, key, value) =>+ m instanceof Map ? [...m].map(([k, x]) => [key(k), value(x)]) : invalid("Map", m);+export const decodePairMap = (v, key, value) => new Map(v.map(([k, x]) => [key(k), value(x)]));++export const encodeMaybe = (x, f) => (x === null ? null : f(x));+export const decodeMaybe = (v, f) => (v === null ? null : f(v));++export const encodeEither = (x, left, right) =>+ x !== null && typeof x === "object" && "Left" in x+ ? { Left: left(x.Left) }+ : x !== null && typeof x === "object" && "Right" in x+ ? { Right: right(x.Right) }+ : invalid("Either", x);+export const decodeEither = (v, left, right) => ("Left" in v ? { Left: left(v.Left) } : { Right: right(v.Right) });++export const encodeTuple = (xs, fs) =>+ Array.isArray(xs) && xs.length === fs.length ? fs.map((f, i) => f(xs[i])) : invalid(`${fs.length}-tuple`, xs);+export const decodeTuple = (v, fs) => fs.map((f, i) => f(v[i]));++// User data types.+export const encodeRecord = (tag, fields) => ({ $tag: tag, ...fields });+export const encodePositional = (tag, args) =>+ args.length === 0 ? { $tag: tag } : { $tag: tag, contents: args.length === 1 ? args[0] : args };+export const encodeEnum = (tag) => tag;++export const decodeTag = (v) => (typeof v === "string" ? v : v?.$tag);+export const decodeField = (v, name) => v[name];+export const decodeArg = (v, i, n) => (n === 1 ? v.contents : v.contents[i]);
+ runtime-js/ghc_wasm_bindgen_runtime.d.ts view
@@ -0,0 +1,5 @@+// Public interface of the ghc-wasm-bindgen runtime.++export { init, HaskellError } from "./ghc_wasm_bindgen_internal";++export type Either<E, A> = { Left: E } | { Right: A };
+ runtime-js/ghc_wasm_bindgen_runtime.js view
@@ -0,0 +1,3 @@+// Public interface of the ghc-wasm-bindgen runtime.++export { init, HaskellError } from "./ghc_wasm_bindgen_internal.js";
+ runtime-js/ghc_wasm_jsffi.d.ts view
@@ -0,0 +1,4 @@+// Types for the output of GHC's post-link.mjs.++declare const jsffiImports: (exports: Record<string, unknown>) => WebAssembly.ModuleImports;+export default jsffiImports;
+ src/GhcWasmBindgen.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Bindings for a Haskell API module, in two modes:+--+-- * 'build' (cabal projects): builds an npm package (JS bindings + .wasm).+-- The package that contains the module is built natively, so the module can+-- be inspected with its real dependencies; then the Haskell bindings are+-- generated, together with the Haskell runtime module, as a package under+-- dist-newstyle/ghc-wasm-bindgen/ and compiled with wasm32-wasi-cabal+-- against the user's own project.+--+-- * 'generate' (plain source files): only writes the bindings, Haskell and+-- JS; compiling them is up to the user.+module GhcWasmBindgen+ ( Options (..)+ , build+ , GenerateOptions (..)+ , generate+ ) where++import Control.Exception (Exception, IOException, throwIO, try)+import Control.Monad (filterM, unless)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BC+import Data.Char (isSpace, toLower, toUpper)+import Data.FileEmbed (embedFile)+import Data.List (intercalate, isSuffixOf, stripPrefix)+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Text.Encoding as TE+import System.Directory+import System.Exit (ExitCode (..))+import System.FilePath+import System.Process+import qualified GHC.Paths++import GhcWasmBindgen.EmitHaskell (emitHaskell)+import GhcWasmBindgen.EmitJavaScript (emitDts, emitJs)+import GhcWasmBindgen.Inspect (InspectOptions (..), Source (..), inspect)+import GhcWasmBindgen.Model (Api)++-- | Options of 'build'.+data Options = Options+ { optModule :: FilePath+ -- ^ The API module.+ , optName :: String+ -- ^ Base name of the outputs: NAME.js, NAME.d.ts, NAME.wasm.+ , optOut :: FilePath+ -- ^ Directory of the npm package to write.+ }++newtype BuildError = BuildError String++instance Show BuildError where+ show (BuildError e) = e++instance Exception BuildError++-- | Run from the user's cabal project directory. Returns the output+-- directory, or the problems that prevent building.+build :: Options -> IO (Either [String] FilePath)+build o = catchErrors $ do+ pkg <- findPackage (optModule o)+ env <- nativeEnvironment pkg+ res <- inspect InspectOptions {inspFile = optModule o, inspSource = PackageEnv env}+ traverse (buildWasm o pkg) res++-- | Options of 'generate'.+data GenerateOptions = GenerateOptions+ { genModule :: FilePath+ , genName :: String+ , genHsOut :: FilePath+ -- ^ Receives NameWasmBindings.hs and GhcWasmBindgen/Runtime.hs.+ , genJsOut :: FilePath+ -- ^ Receives NAME.js, NAME.d.ts and the JS runtime.+ , genImportDirs :: [FilePath]+ }++-- | Writes the bindings for plain source files. Returns the files written.+generate :: GenerateOptions -> IO (Either [String] [FilePath])+generate o = catchErrors $ do+ res <- inspect InspectOptions {inspFile = genModule o, inspSource = SourceFiles (genImportDirs o)}+ traverse write res+ where+ write api =+ mapM (\(path, contents) -> path <$ writeIfChanged path contents) $+ [ (genHsOut o </> hsFileName (genName o), TE.encodeUtf8 (emitHaskell api))+ , (genHsOut o </> "GhcWasmBindgen" </> "Runtime.hs", runtimeHs)+ ]+ ++ [(genJsOut o </> file, contents) | (file, contents) <- jsFiles (genName o) api]++catchErrors :: IO (Either [String] a) -> IO (Either [String] a)+catchErrors act = do+ r <- try (try act)+ pure $ case r of+ Left (e :: IOException) -> Left [show e]+ Right (Left (BuildError e)) -> Left [e]+ Right (Right result) -> result++-- | Builds the package natively and returns a GHC environment file with it+-- and its dependencies (the one @cabal exec@ provides).+nativeEnvironment :: Package -> IO FilePath+nativeEnvironment pkg = do+ let args = ["--builddir=" ++ workDir </> "native", "--with-compiler=" ++ GHC.Paths.ghc]+ run "cabal" (["build"] ++ args ++ [pkgName pkg ++ ":lib:" ++ pkgName pkg])+ env <- output "cabal" (["exec", "-v0"] ++ args ++ ["--", "sh", "-c", "cat \"$GHC_ENVIRONMENT\""])+ path <- makeAbsolute (workDir </> "native.env")+ writeIfChanged path . BC.pack =<< withoutUnbuilt env+ pure path++-- | Drops local packages that were not built (other packages of the project),+-- which GHC would otherwise fail to find.+withoutUnbuilt :: String -> IO String+withoutUnbuilt env = unlines <$> filterM keep ls+ where+ ls = lines env+ dbs = [db | l <- ls, Just db <- [stripPrefix "package-db " l]]+ keep l = case stripPrefix "package-id " l of+ Just uid | "-inplace" `isSuffixOf` uid -> or <$> mapM (\db -> doesFileExist (db </> uid <.> "conf")) dbs+ _ -> pure True++buildWasm :: Options -> Package -> Api -> IO FilePath+buildWasm o pkg api = do+ let name = optName o+ bindingsPkg = cabalName name ++ "-wasm-bindings"+ exe = cabalName name+ target = bindingsPkg ++ ":exe:" ++ exe+ hsFile = hsFileName name+ projectArg = "--project-file=" ++ (workDir </> "cabal.project")++ -- Intermediate Haskell package: the bindings and the runtime module.+ writeIfChanged (workDir </> "bindings" </> bindingsPkg <.> "cabal") (bindingsCabal bindingsPkg exe hsFile (pkgName pkg))+ writeIfChanged (workDir </> "bindings" </> hsFile) (TE.encodeUtf8 (emitHaskell api))+ writeIfChanged (workDir </> "bindings" </> "GhcWasmBindgen" </> "Runtime.hs") runtimeHs+ writeIfChanged (workDir </> "cabal.project") =<< projectFile++ -- Compile, post-link and optimize.+ run "wasm32-wasi-cabal" ["build", projectArg, target]+ wasm <- trim <$> output "wasm32-wasi-cabal" ["list-bin", "-v0", projectArg, target]+ libdir <- trim <$> output "wasm32-wasi-ghc" ["--print-libdir"]+ createDirectoryIfMissing True (optOut o)+ run (libdir </> "post-link.mjs") ["-i", wasm, "-o", optOut o </> "ghc_wasm_jsffi.js"]+ run "wasm-opt" ["-Oz", wasm, "-o", optOut o </> name <.> "wasm"]++ -- JS side.+ mapM_ (\(file, contents) -> writeIfChanged (optOut o </> file) contents) $+ ("package.json", packageJson name (pkgVersion pkg)) : jsFiles name api+ pure (optOut o)++-- | The JS bindings and runtime, by file name.+jsFiles :: String -> Api -> [(FilePath, ByteString)]+jsFiles name api =+ [ (name <.> "js", TE.encodeUtf8 (emitJs api))+ , (name <.> "d.ts", TE.encodeUtf8 (emitDts api))+ , ("ghc_wasm_bindgen_runtime.js", $(embedFile "runtime-js/ghc_wasm_bindgen_runtime.js"))+ , ("ghc_wasm_bindgen_runtime.d.ts", $(embedFile "runtime-js/ghc_wasm_bindgen_runtime.d.ts"))+ , ("ghc_wasm_bindgen_internal.js", $(embedFile "runtime-js/ghc_wasm_bindgen_internal.js"))+ , ("ghc_wasm_bindgen_internal.d.ts", $(embedFile "runtime-js/ghc_wasm_bindgen_internal.d.ts"))+ , ("ghc_wasm_jsffi.d.ts", $(embedFile "runtime-js/ghc_wasm_jsffi.d.ts"))+ ]++runtimeHs :: ByteString+runtimeHs = $(embedFile "runtime-hs/GhcWasmBindgen/Runtime.hs")++workDir :: FilePath+workDir = "dist-newstyle" </> "ghc-wasm-bindgen"++-- Cabal --------------------------------------------------------------------++data Package = Package {pkgName :: String, pkgVersion :: String}++-- | The cabal package that contains the API module: the nearest .cabal file+-- above it.+findPackage :: FilePath -> IO Package+findPackage file = makeAbsolute (takeDirectory file) >>= go+ where+ go dir = do+ cabalFiles <- filter (".cabal" `isSuffixOf`) <$> listDirectory dir+ case cabalFiles of+ f : _ -> do+ fields <- mapMaybe field . lines . BC.unpack <$> BS.readFile (dir </> f)+ case lookup "name" fields of+ Just n -> pure (Package n (fromMaybe "0" (lookup "version" fields)))+ Nothing -> throwIO (BuildError (dir </> f ++ " has no name field"))+ [] | takeDirectory dir == dir -> throwIO (BuildError ("no .cabal file found above " ++ file))+ | otherwise -> go (takeDirectory dir)+ field l = case break (== ':') l of+ (k@(c : _), ':' : v) | not (isSpace c) -> Just (map toLower (trim k), trim v)+ _ -> Nothing++-- | Imports the user's project (absolute paths: cabal resolves imports from+-- the importing file) and adds the generated packages.+projectFile :: IO ByteString+projectFile = do+ root <- getCurrentDirectory+ hasProject <- doesFileExist "cabal.project"+ hasLocal <- doesFileExist "cabal.project.local"+ pure . BC.pack . unlines $+ ["-- Generated by ghc-wasm-bindgen. Do not edit."]+ ++ ["import: " ++ root </> "cabal.project" | hasProject]+ ++ ["import: " ++ root </> "cabal.project.local" | hasLocal]+ ++ ["packages: " ++ unwords (["." | not hasProject] ++ [workDir </> "bindings"])]++bindingsCabal :: String -> String -> FilePath -> String -> ByteString+bindingsCabal pkg exe hsFile userPkg =+ BC.pack . unlines $+ [ "cabal-version: 3.0"+ , "-- Generated by ghc-wasm-bindgen. Do not edit."+ , "name: " ++ pkg+ , "version: 0"+ , "build-type: Simple"+ , ""+ , "executable " ++ exe+ , " main-is: " ++ hsFile+ , " other-modules: GhcWasmBindgen.Runtime"+ , " default-language: GHC2021"+ , " build-depends: base, " ++ userPkg ++ ", aeson >=2.2.1 && <2.3, text, ghc-experimental"+ , " ghc-options: -no-hs-main -optl-mexec-model=reactor"+ ]++-- | @shape@ → @ShapeWasmBindings.hs@, @my-lib@ → @MyLibWasmBindings.hs@.+hsFileName :: String -> FilePath+hsFileName name = concatMap capitalize (words (map dashToSpace name)) ++ "WasmBindings.hs"+ where+ dashToSpace c = if c `elem` ("-_" :: String) then ' ' else c+ capitalize (c : cs) = toUpper c : cs+ capitalize [] = []++-- | Cabal package and component names allow letters, digits and @-@.+cabalName :: String -> String+cabalName = map (\c -> if c == '_' then '-' else c)++-- npm ----------------------------------------------------------------------++packageJson :: String -> String -> ByteString+packageJson name version =+ BC.pack . unlines $+ [ "{"+ , " \"name\": " ++ show (map toLower name) ++ ","+ , " \"version\": " ++ show (semver version) ++ ","+ , " \"type\": \"module\","+ , " \"main\": " ++ show ("./" ++ name ++ ".js") ++ ","+ , " \"types\": " ++ show ("./" ++ name ++ ".d.ts") ++ ","+ , " \"exports\": {"+ , " \".\": { \"types\": " ++ show ("./" ++ name ++ ".d.ts") ++ ", \"default\": " ++ show ("./" ++ name ++ ".js") ++ " },"+ , " \"./runtime\": { \"types\": \"./ghc_wasm_bindgen_runtime.d.ts\", \"default\": \"./ghc_wasm_bindgen_runtime.js\" },"+ , " " ++ show ("./" ++ name ++ ".wasm") ++ ": " ++ show ("./" ++ name ++ ".wasm")+ , " }"+ , "}"+ ]++-- | Cabal versions have any number of components; npm wants exactly three.+semver :: String -> String+semver v = intercalate "." (take 3 (splitOn '.' v ++ repeat "0"))+ where+ splitOn c s = case break (== c) s of+ (a, []) -> [a]+ (a, _ : rest) -> a : splitOn c rest++-- Files and processes ------------------------------------------------------++-- | Leaves the file untouched when it already has these contents, so cabal+-- and GHC don't rebuild for nothing.+writeIfChanged :: FilePath -> ByteString -> IO ()+writeIfChanged path contents = do+ exists <- doesFileExist path+ same <- if exists then (== contents) <$> BS.readFile path else pure False+ unless same $ do+ createDirectoryIfMissing True (takeDirectory path)+ BS.writeFile path contents++run :: FilePath -> [String] -> IO ()+run cmd args = do+ r <- try (withCreateProcess (proc cmd args) (\_ _ _ p -> waitForProcess p))+ case r of+ Left (e :: IOException) -> throwIO (cannotRun cmd e)+ Right ExitSuccess -> pure ()+ Right (ExitFailure c) -> throwIO (BuildError (unwords (cmd : args) ++ " failed (exit code " ++ show c ++ ")"))++output :: FilePath -> [String] -> IO String+output cmd args = do+ r <- try (readCreateProcessWithExitCode (proc cmd args) "")+ case r of+ Left (e :: IOException) -> throwIO (cannotRun cmd e)+ Right (ExitSuccess, out, _) -> pure out+ Right (ExitFailure c, _, err) -> throwIO (BuildError (unwords (cmd : args) ++ " failed (exit code " ++ show c ++ "):\n" ++ err))++cannotRun :: FilePath -> IOException -> BuildError+cannotRun cmd e =+ BuildError ("cannot run " ++ cmd ++ " (" ++ show e ++ "); is the WASM toolchain on PATH? (source ~/.ghc-wasm/env)")++trim :: String -> String+trim = f . f where f = reverse . dropWhile isSpace
+ src/GhcWasmBindgen/EmitHaskell.hs view
@@ -0,0 +1,80 @@+-- | Emits the Haskell bindings module (@NameWasmBindings.hs@): one sync+-- @foreign export javascript@ per function and the aeson instances (with the+-- runtime's fixed options) for every ADT.+--+-- The user's module and the runtime are imported qualified so no exported+-- name can clash with the generated ones.+module GhcWasmBindgen.EmitHaskell (emitHaskell) where++import Data.Text (Text)+import qualified Data.Text as T++import GhcWasmBindgen.Model++-- | The bindings module (@module Main@), ready for wasm32-wasi-ghc.+emitHaskell :: Api -> Text+emitHaskell api =+ T.unlines $+ concat+ [ [ "-- Generated by ghc-wasm-bindgen from " <> apiModule api <> ". Do not edit."+ , ""+ , "{-# LANGUAGE DeriveGeneric, DerivingVia, StandaloneDeriving #-}"+ , "{-# OPTIONS_GHC -Wno-orphans #-}"+ ]+ , ["{-# OPTIONS_GHC -optl-Wl,--export=" <> exportSymbol f <> " #-}" | f <- apiFns api]+ , [ "module Main (main) where"+ , ""+ , "import qualified GhcWasmBindgen.Runtime as R"+ , "import qualified " <> apiModule api <> " as Api"+ , ""+ ]+ , concatMap instances (apiTypes api)+ , concatMap wrapper (apiFns api)+ , ["main :: IO ()", "main = pure ()"]+ ]++instances :: Adt -> [Text]+instances adt =+ ["deriving instance R.Generic " <> ty | adtGeneric adt]+ ++ [ "deriving via R.Bindgen " <> ty <> " instance R.ToJSON " <> ty+ , "deriving via R.Bindgen " <> ty <> " instance R.FromJSON " <> ty+ -- As map keys: the default methods encode the key as its JSON value.+ , "instance R.ToJSONKey " <> ty+ , "instance R.FromJSONKey " <> ty+ , ""+ ]+ where+ ty = "Api." <> adtName adt++wrapper :: Fn -> [Text]+wrapper f =+ [ sym <> " :: " <> sig+ , sym <> T.concat [" " <> a | a <- args] <> " = R.guarded (" <> result <> ")"+ , ""+ , "foreign export javascript \"" <> sym <> " sync\" " <> sym <> " :: " <> sig+ , ""+ ]+ where+ sym = exportSymbol f+ args = ["a" <> T.pack (show i) | i <- [0 .. length (fnArgs f) - 1 :: Int]]+ sig = T.intercalate " -> " (map ffiType (fnArgs f) ++ ["IO " <> ffiType (fnResult f)])+ call = T.unwords (("Api." <> fnName f) : zipWith argIn (fnArgs f) args)+ result = case marshal (fnResult f) of+ Native -> call+ Str -> "R.toJSString (" <> call <> ")"+ TextStr -> "R.toJSText (" <> call <> ")"+ Json -> "R.toJS (" <> call <> ")"++argIn :: Ty -> Text -> Text+argIn ty a = case marshal ty of+ Native -> a+ Str -> "(R.fromJSString " <> a <> ")"+ TextStr -> "(R.fromJSText " <> a <> ")"+ Json -> "(R.fromJS " <> a <> ")"++ffiType :: Ty -> Text+ffiType = \case+ TDouble -> "Double"+ TInt -> "Int"+ TBool -> "Bool"+ _ -> "R.JSString"
+ src/GhcWasmBindgen/EmitJavaScript.hs view
@@ -0,0 +1,343 @@+-- | Emits the JS side of the bindings: @NAME.js@ (constructors, an+-- encode/decode function per type, the API functions) and @NAME.d.ts@ (their+-- TypeScript types).+--+-- The generated code never sees how values cross to Haskell: it converts+-- them with the encode/decode functions of ghc_wasm_bindgen_internal.js, which+-- must match the aeson options in @GhcWasmBindgen.Runtime@.+module GhcWasmBindgen.EmitJavaScript (emitJs, emitDts) where++import Data.List (intercalate)+import Data.Text (Text)+import qualified Data.Text as T++import GhcWasmBindgen.Model++header :: Api -> Text+header api = "// Generated by ghc-wasm-bindgen from " <> apiModule api <> ". Do not edit."++-- | @NAME.js@+emitJs :: Api -> Text+emitJs api =+ T.unlines $+ [header api, "", "import * as $rt from \"./ghc_wasm_bindgen_internal.js\";", ""]+ ++ concatMap jsType (apiTypes api)+ ++ intercalate [""] (map jsFunction (apiFns api))++-- | @NAME.d.ts@+emitDts :: Api -> Text+emitDts api =+ T.unlines $+ [header api, "", "import type * as $rt from \"./ghc_wasm_bindgen_runtime\";", ""]+ ++ concatMap dtsType (apiTypes api)+ ++ map dtsFunction (apiFns api)++-- Declarations (.d.ts) -----------------------------------------------------++dtsType :: Adt -> [Text]+dtsType adt+ | isAllNullary adt =+ ("export type " <> name <> " = " <> T.intercalate " | " (map (quote . conName) cons) <> ";")+ : [ "export const " <> conName c <> ": " <> name <> ";" | c <- cons ]+ ++ [""]+ | otherwise = typeLine ++ [""] ++ map constructor cons ++ [""]+ where+ name = adtName adt+ cons = adtCons adt+ typeLine = case cons of+ [c] -> ["export type " <> name <> " = " <> conType c <> ";"]+ _ -> ("export type " <> name <> " =") : [ " | " <> conType c <> end | (c, end) <- zip cons (map (const "") (drop 1 cons) ++ [";"]) ]+ constructor c+ | nullary c = "export const " <> conName c <> ": " <> name <> ";"+ | otherwise = "export function " <> conName c <> "(" <> typedParams c <> "): " <> name <> ";"++dtsFunction :: Fn -> Text+dtsFunction f =+ "export function " <> jsIdent (fnName f) <> "("+ <> T.intercalate ", " [a <> ": " <> tsType t | (a, t) <- zip (fnParams f) (fnArgs f)]+ <> "): " <> tsType (fnResult f) <> ";"++-- | @{ $tag: "Rect"; width: number; height: number }@+conType :: Con -> Text+conType c = "{ " <> T.intercalate "; " (("$tag: " <> quote (conName c)) : fields) <> " }"+ where+ fields = case conFields c of+ Record fs -> [key f <> ": " <> tsType t | (f, t) <- fs]+ Positional [] -> []+ Positional [t] -> ["contents: " <> tsType t]+ Positional ts -> ["contents: " <> tuple ts]++-- | Record constructors take an object (@fields: { width: number; … }@),+-- positional ones take one argument per field.+typedParams :: Con -> Text+typedParams c = case conFields c of+ Record fs -> "fields: { " <> T.intercalate "; " [key f <> ": " <> tsType t | (f, t) <- fs] <> " }"+ Positional ts -> T.intercalate ", " [p <> ": " <> tsType t | (p, t) <- zip (conParams c) ts]++tsType :: Ty -> Text+tsType = \case+ TDouble -> "number"+ TFloat -> "number"+ TInt -> "number"+ TWord -> "number"+ TIntN _ -> "number"+ TWordN _ -> "number"+ TInteger -> "bigint"+ TNatural -> "bigint"+ TBool -> "boolean"+ TChar -> "string"+ TString -> "string"+ TText -> "string"+ TDay -> "string"+ TUTCTime -> "Date"+ TList t -> element t <> "[]"+ TVector t -> element t <> "[]"+ TNonEmpty t -> "[" <> tsType t <> ", ..." <> element t <> "[]]"+ TSet t -> "Set<" <> tsType t <> ">"+ TMap k v -> "Map<" <> tsType k <> ", " <> tsType v <> ">"+ TIntMap v -> "Map<number, " <> tsType v <> ">"+ TMaybe t -> tsType t <> " | null"+ TEither l r -> "$rt.Either<" <> tsType l <> ", " <> tsType r <> ">"+ TTuple ts -> tuple ts+ TAdt n -> n+ where+ element t@(TMaybe _) = "(" <> tsType t <> ")"+ element t = tsType t++tuple :: [Ty] -> Text+tuple ts = "[" <> T.intercalate ", " (map tsType ts) <> "]"++-- Implementation (.js) -----------------------------------------------------++jsType :: Adt -> [Text]+jsType adt+ | isAllNullary adt =+ [ "export const " <> conName c <> " = " <> quote (conName c) <> ";" | c <- cons ]+ ++ [""] ++ enumCoders adt+ | otherwise = map constructor cons ++ [""] ++ coders adt+ where+ cons = adtCons adt+ constructor c+ | nullary c = "export const " <> conName c <> " = " <> conValue c <> ";"+ | otherwise = "export const " <> conName c <> " = (" <> jsParams c <> ") => (" <> conValue c <> ");"++jsFunction :: Fn -> [Text]+jsFunction f = [lhs, " " <> body]+ where+ lhs = "export const " <> jsIdent (fnName f) <> " = (" <> T.intercalate ", " (fnParams f) <> ") =>"+ body = result ("$rt.call(" <> T.intercalate ", " (quote (exportSymbol f) : zipWith arg (fnArgs f) (fnParams f)) <> ")") <> ";"+ result e+ | marshal (fnResult f) == Json = decode (fnResult f) ("$rt.unpack(" <> e <> ")")+ | fnResult f == TBool = "$rt.unpackBool(" <> e <> ")"+ | otherwise = e+ -- Every argument goes through its encoder, which checks it; JSON ones+ -- are then packed.+ arg t a+ | marshal t == Json = "$rt.pack(" <> encode t a <> ")"+ | otherwise = encode t a++-- | @{ width, height }@ (destructured object) or @a0, a1@.+jsParams :: Con -> Text+jsParams c = case conFields c of+ Record _ -> "{ " <> T.intercalate ", " (recordBindings c) <> " }"+ Positional _ -> T.intercalate ", " (conParams c)++-- | @width@, or @"admin'": admin_@ when the key is not a valid variable name.+recordBindings :: Con -> [Text]+recordBindings c = case conFields c of+ Record fs -> [if key f == p then key f else key f <> ": " <> p | ((f, _), p) <- zip fs (conParams c)]+ Positional _ -> []++-- | @{ $tag: "Rect", width, height }@+conValue :: Con -> Text+conValue c = "{ " <> T.intercalate ", " (("$tag: " <> quote (conName c)) : fields) <> " }"+ where+ fields = case conFields c of+ Record _ -> recordBindings c+ Positional [] -> []+ Positional [_] -> ["contents: a0"]+ Positional _ -> ["contents: [" <> T.intercalate ", " (conParams c) <> "]"]++-- | @encodeShape@ and @decodeShape@: one case per constructor; anything+-- else is rejected.+coders :: Adt -> [Text]+coders adt =+ ["function encode" <> name <> "(v) {", " switch (v.$tag) {"]+ ++ concat [caseLines c (encodeCon c) | c <- adtCons adt]+ ++ [" }", " return $rt.invalid(" <> quote name <> ", v);", "}", ""]+ ++ ["function decode" <> name <> "(v) {", " switch ($rt.decodeTag(v)) {"]+ ++ concat [caseLines c (decodeCon c) | c <- adtCons adt]+ ++ [" }", " return $rt.invalid(" <> quote name <> ", v);", "}", ""]+ where+ name = adtName adt++-- | @case "Rect": return …;@, continuing the expression's lines.+caseLines :: Con -> [Text] -> [Text]+caseLines c expr = case expr of+ [] -> []+ e : es -> zipWith (<>) (" case " <> quote (conName c) <> ": return " : repeat " ") (e : es) `withLast` (<> ";")+ where+ withLast xs g = init xs ++ [g (last xs)]++-- | Same for a type whose constructors all have no fields.+enumCoders :: Adt -> [Text]+enumCoders adt =+ [ "function encode" <> name <> "(v) {"+ , " switch (v) {"+ , " " <> T.unwords ["case " <> quote (conName c) <> ":" | c <- adtCons adt] <> " return $rt.encodeEnum(v);"+ , " }"+ , " return $rt.invalid(" <> quote name <> ", v);"+ , "}"+ , ""+ , "function decode" <> name <> "(v) {"+ , " switch ($rt.decodeTag(v)) {"+ ]+ ++ [ " case " <> quote (conName c) <> ": return " <> conName c <> ";" | c <- adtCons adt ]+ ++ [" }", " return $rt.invalid(" <> quote name <> ", v);", "}", ""]+ where+ name = adtName adt++-- | @$rt.encodeRecord("Rect", { width: $rt.encodeDouble(v.width), … })@,+-- one record field per line.+encodeCon :: Con -> [Text]+encodeCon c = case conFields c of+ Record fs ->+ ["$rt.encodeRecord(" <> tag <> ", {"]+ ++ [" " <> key f <> ": " <> encode t (field "v" f) <> "," | (f, t) <- fs]+ ++ ["})"]+ Positional ts -> ["$rt.encodePositional(" <> tag <> ", [" <> T.intercalate ", " (args ts) <> "])"]+ where+ tag = quote (conName c)+ args [t] = [encode t "v.contents"]+ args ts = [encode t (index "v.contents" i) | (i, t) <- zip [0 ..] ts]++-- | @Rect({ width: $rt.decodeNumber($rt.decodeField(v, "width")), … })@,+-- through the constructor, one record field per line.+decodeCon :: Con -> [Text]+decodeCon c = case conFields c of+ _ | nullary c -> [conName c]+ Record fs ->+ [conName c <> "({"]+ ++ [" " <> key f <> ": " <> decode t ("$rt.decodeField(v, " <> quote f <> ")") <> "," | (f, t) <- fs]+ ++ ["})"]+ Positional ts ->+ [conName c <> "(" <> T.intercalate ", " [decode t ("$rt.decodeArg(v, " <> showT i <> ", " <> showT (length ts) <> ")") | (i, t) <- zip [0 ..] ts] <> ")"]++-- | Expression that encodes the value @v@ of type @t@.+encode :: Ty -> Text -> Text+encode t v = case t of+ TList a -> "$rt.encodeList(" <> v <> ", " <> encoder a <> ")"+ TVector a -> "$rt.encodeList(" <> v <> ", " <> encoder a <> ")"+ TNonEmpty a -> "$rt.encodeNonEmpty(" <> v <> ", " <> encoder a <> ")"+ TSet a -> "$rt.encodeSet(" <> v <> ", " <> encoder a <> ")"+ TMap k x+ | isTextKey k -> "$rt.encodeTextKeyMap(" <> v <> ", " <> encoder k <> ", " <> encoder x <> ")"+ | otherwise -> "$rt.encodePairMap(" <> v <> ", " <> encoder k <> ", " <> encoder x <> ")"+ TIntMap x -> "$rt.encodePairMap(" <> v <> ", $rt.encodeInt, " <> encoder x <> ")"+ TMaybe a -> "$rt.encodeMaybe(" <> v <> ", " <> encoder a <> ")"+ TEither l r -> "$rt.encodeEither(" <> v <> ", " <> encoder l <> ", " <> encoder r <> ")"+ TTuple ts -> "$rt.encodeTuple(" <> v <> ", [" <> T.intercalate ", " (map encoder ts) <> "])"+ _ -> encoder t <> "(" <> v <> ")"++-- | Function that encodes (and checks) a value of type @t@.+encoder :: Ty -> Text+encoder = \case+ TDouble -> "$rt.encodeDouble"+ TFloat -> "$rt.encodeFloat"+ TInt -> "$rt.encodeInt"+ TWord -> "$rt.encodeWord"+ TIntN n -> "$rt.encodeInt" <> showT n+ TWordN n -> "$rt.encodeWord" <> showT n+ TInteger -> "$rt.encodeInteger"+ TNatural -> "$rt.encodeNatural"+ TBool -> "$rt.encodeBool"+ TChar -> "$rt.encodeChar"+ TString -> "$rt.encodeString"+ TText -> "$rt.encodeString"+ TDay -> "$rt.encodeDay"+ TUTCTime -> "$rt.encodeUTCTime"+ TAdt n -> "encode" <> n+ t -> "(x) => " <> encode t "x"++-- | Expression that decodes the Value @v@ as type @t@.+decode :: Ty -> Text -> Text+decode t v = case t of+ TList a -> "$rt.decodeList(" <> v <> ", " <> decoder a <> ")"+ TVector a -> "$rt.decodeList(" <> v <> ", " <> decoder a <> ")"+ TNonEmpty a -> "$rt.decodeList(" <> v <> ", " <> decoder a <> ")"+ TSet a -> "$rt.decodeSet(" <> v <> ", " <> decoder a <> ")"+ TMap k x+ | isTextKey k -> "$rt.decodeTextKeyMap(" <> v <> ", " <> decoder k <> ", " <> decoder x <> ")"+ | otherwise -> "$rt.decodePairMap(" <> v <> ", " <> decoder k <> ", " <> decoder x <> ")"+ TIntMap x -> "$rt.decodePairMap(" <> v <> ", $rt.decodeNumber, " <> decoder x <> ")"+ TMaybe a -> "$rt.decodeMaybe(" <> v <> ", " <> decoder a <> ")"+ TEither l r -> "$rt.decodeEither(" <> v <> ", " <> decoder l <> ", " <> decoder r <> ")"+ TTuple ts -> "$rt.decodeTuple(" <> v <> ", [" <> T.intercalate ", " (map decoder ts) <> "])"+ _ -> decoder t <> "(" <> v <> ")"++-- | Function that decodes a Value as type @t@.+decoder :: Ty -> Text+decoder = \case+ TInteger -> "$rt.decodeInteger"+ TNatural -> "$rt.decodeInteger"+ TBool -> "$rt.decodeBool"+ TChar -> "$rt.decodeString"+ TString -> "$rt.decodeString"+ TText -> "$rt.decodeString"+ TDay -> "$rt.decodeString"+ TUTCTime -> "$rt.decodeUTCTime"+ TAdt n -> "decode" <> n+ t | isNumber t -> "$rt.decodeNumber"+ | otherwise -> "(x) => " <> decode t "x"+ where+ isNumber = (`elem` [TDouble, TFloat, TInt, TWord]) <||> (\case TIntN _ -> True; TWordN _ -> True; _ -> False)+ (f <||> g) x = f x || g x++-- Names --------------------------------------------------------------------++nullary :: Con -> Bool+nullary c = null (conTypes c)++conTypes :: Con -> [Ty]+conTypes c = case conFields c of+ Record fs -> map snd fs+ Positional ts -> ts++-- | Constructor parameters: field names (valid, non-reserved identifiers) or+-- @a0@, @a1@… for positional fields.+conParams :: Con -> [Text]+conParams c = case conFields c of+ Record fs -> map (jsIdent . fst) fs+ Positional ts -> numbered (length ts)++fnParams :: Fn -> [Text]+fnParams f = numbered (length (fnArgs f))++numbered :: Int -> [Text]+numbered n = ["a" <> showT i | i <- [0 .. n - 1]]++-- | Field name as an object key (quoted when it is not a plain identifier,+-- e.g. a Haskell field with a prime).+key :: Text -> Text+key f+ | isPlainIdent f = f+ | otherwise = quote f++-- | @v.width@, or @v["admin'"]@ for keys that need quoting.+field :: Text -> Text -> Text+field v f+ | isPlainIdent f = v <> "." <> f+ | otherwise = v <> "[" <> quote f <> "]"++index :: Text -> Int -> Text+index v i = v <> "[" <> showT i <> "]"++showT :: Int -> Text+showT = T.pack . show++quote :: Text -> Text+quote t = "\"" <> T.concatMap esc t <> "\""+ where+ esc '"' = "\\\""+ esc '\\' = "\\\\"+ esc c = T.singleton c
+ src/GhcWasmBindgen/Inspect.hs view
@@ -0,0 +1,326 @@+-- | Reads the export module with the GHC API and builds the+-- 'GhcWasmBindgen.Model.Api' model.+--+-- This is the only module that imports GHC; a GHC upgrade should only touch+-- this file.+module GhcWasmBindgen.Inspect+ ( InspectOptions (..)+ , Source (..)+ , inspect+ ) where++import Control.Monad (filterM, forM, forM_, unless, when)+import Control.Monad.IO.Class (liftIO)+import Data.IORef+import Data.List (isPrefixOf, nub, sortOn)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, listToMaybe)+import qualified Data.Set as Set+import qualified Data.Text as T+import System.Directory (makeAbsolute)+import System.FilePath (joinPath, splitDirectories, takeDirectory)++import GHC+import GHC.Builtin.Types (boolTyCon, charTyCon, doubleTyCon, floatTyCon, intTyCon, integerTyCon, listTyCon, maybeTyCon, naturalTyCon, wordTyCon)+import GHC.Core.DataCon (dataConOrigArgTys)+import GHC.Core.InstEnv (ClsInst (..))+import GHC.Core.Multiplicity (scaledThing)+import GHC.Core.TyCon (isAlgTyCon, isBoxedTupleTyCon, tyConName)+import GHC.Core.Type (expandTypeSynonyms, mkTyConTy, splitFunTy_maybe, splitFunTys, splitTyConApp_maybe)+import GHC.Data.FastString (unpackFS)+import GHC.Data.StringBuffer (hGetStringBuffer)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Parser.Header (getImports)+import GHC.Paths (libdir)+import GHC.Tc.Utils.TcType (tcSplitSigmaTy)+import GHC.Types.FieldLabel (flLabel)+import GHC.Types.Name (getOccString, isSymOcc, nameModule_maybe, nameOccName)+import GHC.Unit.Types (unitString)+import GHC.Utils.Outputable (showPprUnsafe)+import Language.Haskell.Syntax.Basic (field_label)++import GhcWasmBindgen.Model++-- | What to inspect, and where its code comes from.+data InspectOptions = InspectOptions+ { inspFile :: FilePath+ -- ^ The API module's source; its module name is read from the header.+ , inspSource :: Source+ }++-- | Where the module's code and its dependencies come from.+data Source+ = PackageEnv FilePath+ -- ^ Read the module, already compiled, from the packages of this GHC+ -- environment file (written by cabal).+ | SourceFiles [FilePath]+ -- ^ Typecheck the module from source, with these extra import+ -- directories (its own source root is added) and the global package+ -- database.++-- | Describe what the module exports. On failure, returns every problem found+-- (not just the first).+inspect :: InspectOptions -> IO (Either [String] Api)+inspect opts = do+ file <- makeAbsolute (inspFile opts)+ runGhc (Just libdir) $ do+ dflags0 <- getSessionDynFlags+ logger <- getLogger+ -- "-" ignores ambient package environments, so the result does not+ -- depend on the machine.+ let env = case inspSource opts of+ PackageEnv e -> e+ SourceFiles _ -> "-"+ (dflags1, _, _) <- parseDynamicFlags logger dflags0 [noLoc "-package-env", noLoc env]+ modName <- liftIO (readModuleName dflags1 file)+ dirs <- case inspSource opts of+ PackageEnv _ -> pure []+ SourceFiles extra -> liftIO ((:) (sourceRoot file modName) <$> mapM makeAbsolute extra)+ _ <- setSessionDynFlags dflags1 {ghcLink = NoLink, backend = noBackend, importPaths = dirs ++ importPaths dflags1}+ ok <- case inspSource opts of+ PackageEnv _ -> pure True+ SourceFiles _ -> do+ target <- guessTarget file Nothing Nothing+ setTargets [target]+ succeeded <$> load LoadAllTargets+ if not ok+ then pure (Left ["GHC could not typecheck " ++ inspFile opts ++ " (errors above)"])+ else do+ setContext [IIDecl (simpleImportDecl (mkModuleName modName))]+ apiMod <- lookupModule (mkModuleName modName) Nothing+ describe modName apiMod++-- | Module name from the file header, without typechecking anything.+readModuleName :: DynFlags -> FilePath -> IO String+readModuleName dflags file = do+ buf <- hGetStringBuffer file+ res <- getImports (initParserOpts dflags) False buf file file+ case res of+ Right (_, _, _, L _ m) -> pure (moduleNameString m)+ Left _ -> fail ("could not parse the module header of " ++ file)++-- | @/x/src/Foo/Api.hs@ with module @Foo.Api@ → @/x/src@.+sourceRoot :: FilePath -> String -> FilePath+sourceRoot file modName+ | modDirs == take n comps = joinPath rootDirs+ | otherwise = takeDirectory file+ where+ comps = splitOn modName+ dirs = splitDirectories (takeDirectory file)+ n = length comps - 1+ (rootDirs, modDirs) = splitAt (length dirs - n) dirs+ splitOn s = case break (== '.') s of+ (a, []) -> [a]+ (a, _ : rest) -> a : splitOn rest++------------------------------------------------------------------------------++describe :: String -> Module -> Ghc (Either [String] Api)+describe modName apiMod = do+ Just info <- getModuleInfo apiMod+ let exports = modInfoExports info+ exported = Set.fromList exports+ things <- catMaybes <$> mapM lookupName exports++ errs <- liftIO (newIORef [])+ let report e = modifyIORef' errs (e :)++ -- Functions.+ fns <- liftIO $ fmap catMaybes $ forM things $ \case+ AnId i | not (isRecordSelector i) -> do+ let name = getOccString i+ if isSymOcc (nameOccName (getName i))+ then Nothing <$ report ("(" ++ name ++ "): operators cannot be exported; export a named alias instead")+ else case runConv (fnFromType (idType i)) of+ Left e -> Nothing <$ report (name ++ " :: " ++ showPprUnsafe (idType i) ++ "\n " ++ e)+ Right ((args, res), tcs) -> pure (Just (Fn (T.pack name) args res, tcs))+ _ -> pure Nothing++ -- Data types: every exported one plus everything reachable from them and+ -- from the function signatures.+ let exportedTcs = [tc | ATyCon tc <- things, isAlgTyCon tc, not (isClassTyCon tc)]+ adts <- liftIO (closure report exported (exportedTcs ++ concatMap snd fns))++ -- Instances the generated code would otherwise duplicate.+ hasGeneric <- Set.fromList . map (tyConName . fst) <$> filterM (hasInstance genericClass . fst) adts+ hasJson <- filterM (\(tc, _) -> (||) <$> hasInstance toJsonClass tc <*> hasInstance fromJsonClass tc) adts+ forM_ hasJson $ \(tc, _) ->+ liftIO (report (getOccString tc ++ ": already has aeson instances; ghc-wasm-bindgen derives its own with fixed options, remove them from the core"))++ -- Mangled JS names must stay distinct.+ let jsNames = [(jsIdent (fnName f), fnName f) | (f, _) <- fns]+ forM_ (Map.toList (Map.fromListWith (++) [(j, [h]) | (j, h) <- jsNames])) $ \(j, hs) ->+ when (length hs > 1) $+ liftIO (report ("functions " ++ show hs ++ " would all be exported to JS as " ++ show j))++ problems <- liftIO (readIORef errs)+ pure $+ if null problems+ then Right Api+ { apiModule = T.pack modName+ , apiTypes = sortOn adtName [adt {adtGeneric = tyConName tc `Set.notMember` hasGeneric} | (tc, adt) <- adts]+ , apiFns = sortOn fnName (map fst fns)+ }+ else Left (reverse problems)++-- | A class, as (name, modules that may define it).+type ClassRef = (String, [String])++genericClass, toJsonClass, fromJsonClass :: ClassRef+genericClass = ("Generic", ["GHC.Generics", "GHC.Internal.Generics"])+toJsonClass = ("ToJSON", ["Data.Aeson.Types.ToJSON"])+fromJsonClass = ("FromJSON", ["Data.Aeson.Types.FromJSON"])++-- | Whether a visible instance of the class exists for the type.+hasInstance :: ClassRef -> TyCon -> Ghc Bool+hasInstance (cls, mods) tc = any matches <$> getInstancesForType (mkTyConTy tc)+ where+ matches inst =+ getOccString (is_cls_nm inst) == cls+ && maybe False ((`elem` mods) . moduleNameString . moduleName) (nameModule_maybe (is_cls_nm inst))++-- | Converts every reachable type constructor, reporting unsupported ones.+-- Keeps first-seen order (exported types first).+closure :: (String -> IO ()) -> Set.Set Name -> [TyCon] -> IO [(TyCon, Adt)]+closure report exported = go Set.empty []+ where+ go _ acc [] = pure (reverse acc)+ go seen acc (tc : rest)+ | tyConName tc `Set.member` seen = go seen acc rest+ | otherwise = do+ let seen' = Set.insert (tyConName tc) seen+ case runConv (adtFromTyCon tc) of+ Left e -> report (getOccString tc ++ ": " ++ e) >> go seen' acc rest+ Right (adt, more) -> do+ let missing =+ [getOccString tc | tyConName tc `Set.notMember` exported]+ ++ [ getOccString tc ++ "(" ++ T.unpack (conName c) ++ ")"+ | (c, dc) <- zip (adtCons adt) (tyConDataCons tc)+ , getName dc `Set.notMember` exported+ ]+ unless (null missing) $+ report (getOccString tc ++ ": used by the API, so the type and all its constructors must be exported (" ++ unwords (nub missing) ++ " missing); add `" ++ getOccString tc ++ " (..)` to the export list")+ go seen' ((tc, adt) : acc) (rest ++ more)++------------------------------------------------------------------------------+-- Type conversion. Collects the data types it encounters.++newtype Conv a = Conv {runConv :: Either String (a, [TyCon])}++instance Functor Conv where+ fmap f (Conv r) = Conv (fmap (\(a, w) -> (f a, w)) r)++instance Applicative Conv where+ pure a = Conv (Right (a, []))+ Conv f <*> Conv a = Conv $ do+ (g, w1) <- f+ (x, w2) <- a+ pure (g x, w1 ++ w2)++instance Monad Conv where+ Conv a >>= k = Conv $ do+ (x, w1) <- a+ (y, w2) <- runConv (k x)+ pure (y, w1 ++ w2)++failConv :: String -> Conv a+failConv e = Conv (Left e)++tell :: TyCon -> Conv ()+tell tc = Conv (Right ((), [tc]))++fnFromType :: Type -> Conv ([Ty], Ty)+fnFromType ty = do+ let (tvs, theta, tau) = tcSplitSigmaTy ty+ unless (null tvs) $ failConv "polymorphic functions are not supported; give the export a concrete type"+ unless (null theta) $ failConv "constraints are not supported; give the export a concrete type"+ let (args, res) = splitFunTys tau+ (,) <$> mapM (toTy . scaledThing) args <*> resultTy res+ where+ resultTy r = case splitTyConApp_maybe (expandTypeSynonyms r) of+ Just (tc, _) | getOccString tc == "IO" -> failConv "IO is not supported yet; exports must be pure"+ _ -> toTy r++toTy :: Type -> Conv Ty+toTy t0 = do+ let t = expandTypeSynonyms t0+ case splitFunTy_maybe t of+ Just _ -> failConv ("function-typed values cannot cross the boundary yet: " ++ showPprUnsafe t0)+ Nothing -> case splitTyConApp_maybe t of+ Nothing -> failConv ("unsupported type " ++ showPprUnsafe t0)+ Just (tc, args) -> case args of+ []+ | tc == doubleTyCon -> pure TDouble+ | tc == floatTyCon -> pure TFloat+ | tc == intTyCon -> pure TInt+ | tc == wordTyCon -> pure TWord+ | tc == integerTyCon -> pure TInteger+ | tc == naturalTyCon -> pure TNatural+ | tc == boolTyCon -> pure TBool+ | tc == charTyCon -> pure TChar+ | Just n <- sized "Int" intModules -> pure (TIntN n)+ | Just n <- sized "Word" wordModules -> pure (TWordN n)+ | is "Text" ["Data.Text.Internal"] -> pure TText+ | is "Day" ["Data.Time.Calendar.Days"] -> pure TDay+ | is "UTCTime" ["Data.Time.Clock.Internal.UTCTime"] -> pure TUTCTime+ | is "IntSet" ["Data.IntSet.Internal"] -> pure (TSet TInt)+ [a]+ | tc == listTyCon -> case splitTyConApp_maybe a of+ Just (c, []) | c == charTyCon -> pure TString+ _ -> TList <$> toTy a+ | tc == maybeTyCon -> TMaybe <$> toTy a+ | is "Vector" ["Data.Vector"] -> TVector <$> toTy a+ | is "NonEmpty" ["GHC.Base", "GHC.Internal.Base"] -> TNonEmpty <$> toTy a+ | is "Set" ["Data.Set.Internal"] || is "HashSet" ["Data.HashSet.Internal"] -> TSet <$> toTy a+ | is "IntMap" ["Data.IntMap.Internal"] -> TIntMap <$> toTy a+ [k, v]+ | is "Either" ["Data.Either", "GHC.Internal.Data.Either"] -> TEither <$> toTy k <*> toTy v+ | is "Map" ["Data.Map.Internal"] || is "HashMap" ["Data.HashMap.Internal"] -> do+ key <- toTy k+ case key of+ TAdt _ -> pure ()+ _ | isTextKey key -> pure ()+ _ -> failConv ("unsupported map key type " ++ showPprUnsafe k ++ "; use a string, number, Bool, Char, date or one of your data types")+ TMap key <$> toTy v+ _+ | isBoxedTupleTyCon tc, length args >= 2 -> TTuple <$> mapM toTy args+ | isAlgTyCon tc, not (isClassTyCon tc), not (fromBase tc) ->+ if null args+ then TAdt (T.pack (getOccString tc)) <$ tell tc+ else failConv ("types with parameters are not supported yet: " ++ showPprUnsafe t0)+ | otherwise -> failConv ("unsupported type " ++ showPprUnsafe t0)+ where+ is occ mods =+ getOccString tc == occ+ && maybe False ((`elem` mods) . moduleNameString . moduleName) (nameModule_maybe (tyConName tc))+ -- Int8 … Int64, Word8 … Word64.+ sized prefix mods =+ listToMaybe [n | n <- [8, 16, 32, 64], is (prefix ++ show n) mods]+ intModules = ["GHC.Int", "GHC.Internal.Int"]+ wordModules = ["GHC.Word", "GHC.Internal.Word"]++-- | Types from GHC's own libraries (Char, Integer, Float, …), which are not+-- supported unless listed above.+fromBase :: TyCon -> Bool+fromBase tc = case nameModule_maybe (tyConName tc) of+ Just m -> any (\p -> u == p || (p ++ "-") `isPrefixOf` u) ["base", "ghc-internal", "ghc-prim", "ghc-bignum"]+ where+ u = unitString (moduleUnit m)+ Nothing -> False++adtFromTyCon :: TyCon -> Conv Adt+adtFromTyCon tc = do+ unless (null (tyConTyVars tc)) $ failConv "types with parameters are not supported yet"+ cons <- forM (tyConDataCons tc) $ \dc -> do+ unless (isVanillaDataCon dc) $ failConv (getOccString dc ++ ": GADTs and existential constructors are not supported")+ tys <- mapM (toTy . scaledThing) (dataConOrigArgTys dc)+ let labels = map (unpackFS . field_label . flLabel) (dataConFieldLabels dc)+ pure Con+ { conName = T.pack (getOccString dc)+ , conFields =+ if null labels+ then Positional tys+ else Record (zip (map T.pack labels) tys)+ }+ when (null cons) $ failConv "empty data types have no values to pass"+ pure Adt {adtName = T.pack (getOccString tc), adtCons = cons, adtGeneric = True}
+ src/GhcWasmBindgen/Model.hs view
@@ -0,0 +1,177 @@+-- | Intermediate representation between "GhcWasmBindgen.Inspect" (the only+-- module that talks to the GHC API) and the two emitters.+module GhcWasmBindgen.Model+ ( Api (..)+ , Fn (..)+ , Adt (..)+ , Con (..)+ , Fields (..)+ , Ty (..)+ , Marshal (..)+ , marshal+ , isTextKey+ , isAllNullary+ , jsIdent+ , exportSymbol+ , isPlainIdent+ ) where++import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper)+import Data.Text (Text)+import qualified Data.Text as T++-- | Everything the export module exposes.+data Api = Api+ { apiModule :: Text+ -- ^ Haskell module name, e.g. @WasmApi@.+ , apiTypes :: [Adt]+ -- ^ Data types that cross the boundary, sorted by name (deterministic output).+ , apiFns :: [Fn]+ -- ^ Exported functions, sorted by name.+ }+ deriving (Eq, Show)++-- | An exported function.+data Fn = Fn+ { fnName :: Text+ -- ^ Haskell name.+ , fnArgs :: [Ty]+ , fnResult :: Ty+ }+ deriving (Eq, Show)++-- | A data type used by the API.+data Adt = Adt+ { adtName :: Text+ , adtCons :: [Con]+ , adtGeneric :: Bool+ -- ^ The generated Haskell module must derive @Generic@ (False when the core already has it).+ }+ deriving (Eq, Show)++-- | A data constructor.+data Con = Con+ { conName :: Text+ , conFields :: Fields+ }+ deriving (Eq, Show)++-- | A constructor's fields: named (record) or positional.+data Fields+ = Record [(Text, Ty)]+ | Positional [Ty]+ deriving (Eq, Show)++-- | Types that may appear in an exported signature.+data Ty+ = TDouble+ | TFloat+ | TInt+ | TWord+ | TIntN Int+ -- ^ Int8, Int16, Int32, Int64.+ | TWordN Int+ -- ^ Word8, Word16, Word32, Word64.+ | TInteger+ | TNatural+ | TBool+ | TChar+ | TString+ | TText+ | TDay+ | TUTCTime+ | TList Ty+ | TVector Ty+ | TNonEmpty Ty+ | TSet Ty+ -- ^ Set, HashSet, IntSet.+ | TMap Ty Ty+ -- ^ Map, HashMap.+ | TIntMap Ty+ | TMaybe Ty+ | TEither Ty Ty+ | TTuple [Ty]+ | TAdt Text+ deriving (Eq, Show)++-- | Map keys that aeson writes as object keys (text); any other key type+-- makes the map an array of pairs.+isTextKey :: Ty -> Bool+isTextKey = \case+ TDouble -> True+ TFloat -> True+ TInt -> True+ TWord -> True+ TIntN _ -> True+ TWordN _ -> True+ TInteger -> True+ TNatural -> True+ TBool -> True+ TChar -> True+ TString -> True+ TText -> True+ TDay -> True+ TUTCTime -> True+ _ -> False++-- | How a value of a top-level argument or result type crosses the JSFFI.+data Marshal+ = Native -- ^ Double, Int, Bool: passed as JS numbers/booleans.+ | Str -- ^ String: JSString, no JSON.+ | TextStr -- ^ Text: JSString, no JSON.+ | Json -- ^ Everything else: JSON in a JSString.+ deriving (Eq, Show)++-- | How a top-level argument or result of this type crosses the JSFFI.+marshal :: Ty -> Marshal+marshal = \case+ TDouble -> Native+ TInt -> Native+ TBool -> Native+ TString -> Str+ TText -> TextStr+ _ -> Json++-- | aeson's @allNullaryToStringTag@ (on by default): a type whose+-- constructors are all nullary is encoded as a bare string.+isAllNullary :: Adt -> Bool+isAllNullary = all nullary . adtCons+ where+ nullary c = case conFields c of+ Positional [] -> True+ Record [] -> True+ _ -> False++-- | A Haskell name as a JS/TS identifier: primes become underscores and+-- reserved words get a trailing underscore (@delete@ → @delete_@).+jsIdent :: Text -> Text+jsIdent n+ | m `elem` reserved = m <> "_"+ | otherwise = m+ where+ m = T.replace "'" "_" n++-- | Name of the wasm export (and therefore C symbol) for a function. The+-- prefix keeps user names like @log@ or @free@ from clashing with libc.+exportSymbol :: Fn -> Text+exportSymbol f = "bg_" <> T.replace "'" "_" (fnName f)++-- | Can be used unquoted as a property key.+isPlainIdent :: Text -> Bool+isPlainIdent t = case T.uncons t of+ Just (c, rest) -> start c && T.all part rest+ Nothing -> False+ where+ start c = isAsciiLower c || isAsciiUpper c || c == '_' || c == '$'+ part c = start c || (isAlphaNum c && c < '\x80')++reserved :: [Text]+reserved =+ [ "arguments", "await", "break", "case", "catch", "class", "const", "continue"+ , "debugger", "default", "delete", "do", "else", "enum", "eval", "export"+ , "extends", "false", "finally", "for", "function", "if", "implements"+ , "import", "in", "instanceof", "interface", "let", "new", "null", "package"+ , "private", "protected", "public", "return", "static", "super", "switch"+ , "this", "throw", "true", "try", "typeof", "var", "void", "while", "with"+ , "yield"+ ]
+ test/Errors.hs view
@@ -0,0 +1,24 @@+-- Unsupported APIs must be rejected with a clear message.+module Errors (tests) where++import Control.Monad (forM)+import Data.List (isInfixOf)++import GhcWasmBindgen.Inspect (InspectOptions (..), Source (..), inspect)++cases :: [(FilePath, String)]+cases =+ [ ("HigherOrder.hs", "function-typed values cannot cross the boundary")+ , ("Operator.hs", "operators cannot be exported")+ , ("Polymorphic.hs", "polymorphic functions are not supported")+ , ("Unexported.hs", "Hidden: used by the API, so the type and all its constructors must be exported")+ , ("UsesIO.hs", "IO is not supported yet")+ ]++tests :: IO Bool+tests = fmap and $ forM cases $ \(file, needle) -> do+ res <- inspect (InspectOptions ("test/errors/" ++ file) (SourceFiles []))+ case res of+ Left errs | any (needle `isInfixOf`) errs -> True <$ putStrLn ("ok " ++ file)+ Left errs -> False <$ putStrLn ("FAIL " ++ file ++ ": expected " ++ show needle ++ ", got:\n" ++ unlines errs)+ Right _ -> False <$ putStrLn ("FAIL " ++ file ++ " was accepted")
+ test/Main.hs view
@@ -0,0 +1,17 @@+module Main (main) where++import Control.Monad (unless)+import System.Exit (exitFailure)++import qualified Errors++-- | Each group prints its own results and returns whether all passed.+groups :: [(String, IO Bool)]+groups =+ [ ("errors", Errors.tests)+ ]++main :: IO ()+main = do+ results <- mapM (\(name, run) -> putStrLn ("# " ++ name) >> run) groups+ unless (and results) exitFailure
+ test/errors/HigherOrder.hs view
@@ -0,0 +1,3 @@+module HigherOrder (apply) where+apply :: (Int -> Int) -> Int -> Int+apply f = f
+ test/errors/Operator.hs view
@@ -0,0 +1,3 @@+module Operator ((<+>)) where+(<+>) :: Int -> Int -> Int+(<+>) = (+)
+ test/errors/Polymorphic.hs view
@@ -0,0 +1,3 @@+module Polymorphic (ident) where+ident :: a -> a+ident x = x
+ test/errors/Unexported.hs view
@@ -0,0 +1,4 @@+module Unexported (make) where+data Hidden = Hidden { n :: Int }+make :: Int -> Hidden+make = Hidden
+ test/errors/UsesIO.hs view
@@ -0,0 +1,3 @@+module UsesIO (now) where+now :: Int -> IO Int+now = pure