diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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` | +| `Map k v`, `HashMap k v`, `IntMap v` | `Map` | + +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 + ``` diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/ghc-wasm-bindgen.cabal b/ghc-wasm-bindgen.cabal new file mode 100644 --- /dev/null +++ b/ghc-wasm-bindgen.cabal @@ -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 diff --git a/runtime-hs/GhcWasmBindgen/Runtime.hs b/runtime-hs/GhcWasmBindgen/Runtime.hs new file mode 100644 --- /dev/null +++ b/runtime-hs/GhcWasmBindgen/Runtime.hs @@ -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 "" diff --git a/runtime-js/ghc_wasm_bindgen_internal.d.ts b/runtime-js/ghc_wasm_bindgen_internal.d.ts new file mode 100644 --- /dev/null +++ b/runtime-js/ghc_wasm_bindgen_internal.d.ts @@ -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; + +/** 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(xs: T[], f: (x: T) => Value): Value; +export function decodeList(v: Value, f: (v: Value) => T): T[]; + +export function encodeNonEmpty(xs: [T, ...T[]], f: (x: T) => Value): Value; + +export function encodeSet(xs: Set, f: (x: T) => Value): Value; +export function decodeSet(v: Value, f: (v: Value) => T): Set; + +/** Maps whose keys aeson writes as object keys (strings, numbers, Bool, Char, dates). */ +export function encodeTextKeyMap(m: Map, key: (k: K) => Value, value: (x: V) => Value): Value; +export function decodeTextKeyMap(v: Value, key: (k: string) => K, value: (v: Value) => V): Map; + +/** Maps written as arrays of pairs (any other key type, and IntMap). */ +export function encodePairMap(m: Map, key: (k: K) => Value, value: (x: V) => Value): Value; +export function decodePairMap(v: Value, key: (v: Value) => K, value: (v: Value) => V): Map; + +export function encodeMaybe(x: T | null, f: (x: T) => Value): Value; +export function decodeMaybe(v: Value, f: (v: Value) => T): T | null; + +export function encodeEither(x: Either, left: (e: E) => Value, right: (a: A) => Value): Value; +export function decodeEither(v: Value, left: (v: Value) => E, right: (v: Value) => A): Either; + +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): 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; diff --git a/runtime-js/ghc_wasm_bindgen_internal.js b/runtime-js/ghc_wasm_bindgen_internal.js new file mode 100644 --- /dev/null +++ b/runtime-js/ghc_wasm_bindgen_internal.js @@ -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]); diff --git a/runtime-js/ghc_wasm_bindgen_runtime.d.ts b/runtime-js/ghc_wasm_bindgen_runtime.d.ts new file mode 100644 --- /dev/null +++ b/runtime-js/ghc_wasm_bindgen_runtime.d.ts @@ -0,0 +1,5 @@ +// Public interface of the ghc-wasm-bindgen runtime. + +export { init, HaskellError } from "./ghc_wasm_bindgen_internal"; + +export type Either = { Left: E } | { Right: A }; diff --git a/runtime-js/ghc_wasm_bindgen_runtime.js b/runtime-js/ghc_wasm_bindgen_runtime.js new file mode 100644 --- /dev/null +++ b/runtime-js/ghc_wasm_bindgen_runtime.js @@ -0,0 +1,3 @@ +// Public interface of the ghc-wasm-bindgen runtime. + +export { init, HaskellError } from "./ghc_wasm_bindgen_internal.js"; diff --git a/runtime-js/ghc_wasm_jsffi.d.ts b/runtime-js/ghc_wasm_jsffi.d.ts new file mode 100644 --- /dev/null +++ b/runtime-js/ghc_wasm_jsffi.d.ts @@ -0,0 +1,4 @@ +// Types for the output of GHC's post-link.mjs. + +declare const jsffiImports: (exports: Record) => WebAssembly.ModuleImports; +export default jsffiImports; diff --git a/src/GhcWasmBindgen.hs b/src/GhcWasmBindgen.hs new file mode 100644 --- /dev/null +++ b/src/GhcWasmBindgen.hs @@ -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 diff --git a/src/GhcWasmBindgen/EmitHaskell.hs b/src/GhcWasmBindgen/EmitHaskell.hs new file mode 100644 --- /dev/null +++ b/src/GhcWasmBindgen/EmitHaskell.hs @@ -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" diff --git a/src/GhcWasmBindgen/EmitJavaScript.hs b/src/GhcWasmBindgen/EmitJavaScript.hs new file mode 100644 --- /dev/null +++ b/src/GhcWasmBindgen/EmitJavaScript.hs @@ -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 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 diff --git a/src/GhcWasmBindgen/Inspect.hs b/src/GhcWasmBindgen/Inspect.hs new file mode 100644 --- /dev/null +++ b/src/GhcWasmBindgen/Inspect.hs @@ -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} diff --git a/src/GhcWasmBindgen/Model.hs b/src/GhcWasmBindgen/Model.hs new file mode 100644 --- /dev/null +++ b/src/GhcWasmBindgen/Model.hs @@ -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" + ] diff --git a/test/Errors.hs b/test/Errors.hs new file mode 100644 --- /dev/null +++ b/test/Errors.hs @@ -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") diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/errors/HigherOrder.hs b/test/errors/HigherOrder.hs new file mode 100644 --- /dev/null +++ b/test/errors/HigherOrder.hs @@ -0,0 +1,3 @@ +module HigherOrder (apply) where +apply :: (Int -> Int) -> Int -> Int +apply f = f diff --git a/test/errors/Operator.hs b/test/errors/Operator.hs new file mode 100644 --- /dev/null +++ b/test/errors/Operator.hs @@ -0,0 +1,3 @@ +module Operator ((<+>)) where +(<+>) :: Int -> Int -> Int +(<+>) = (+) diff --git a/test/errors/Polymorphic.hs b/test/errors/Polymorphic.hs new file mode 100644 --- /dev/null +++ b/test/errors/Polymorphic.hs @@ -0,0 +1,3 @@ +module Polymorphic (ident) where +ident :: a -> a +ident x = x diff --git a/test/errors/Unexported.hs b/test/errors/Unexported.hs new file mode 100644 --- /dev/null +++ b/test/errors/Unexported.hs @@ -0,0 +1,4 @@ +module Unexported (make) where +data Hidden = Hidden { n :: Int } +make :: Int -> Hidden +make = Hidden diff --git a/test/errors/UsesIO.hs b/test/errors/UsesIO.hs new file mode 100644 --- /dev/null +++ b/test/errors/UsesIO.hs @@ -0,0 +1,3 @@ +module UsesIO (now) where +now :: Int -> IO Int +now = pure