EmitJavaScript.hs

-- | Emits the JS side of the bindings: @NAME.js@ (loading of @NAME.wasm@,
-- 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@. Loads @NAME.wasm@, found next to it, with a top-level await:
-- importing the module is enough to use it.
emitJs :: Text -> Api -> Text
emitJs name api =
  T.unlines $
    [ header api
    , ""
    , "import * as $rt from \"./ghc_wasm_bindgen_internal.js\";"
    , ""
    , "export { HaskellError } from \"./ghc_wasm_bindgen_internal.js\";"
    , ""
    , "await $rt.load(new URL(" <> quote ("./" <> name <> ".wasm") <> ", import.meta.url));"
    , ""
    ]
      ++ concatMap jsType (apiTypes api)
      ++ intercalate [""] (map jsFunction (apiFns api))

-- | @NAME.d.ts@. Its imports name the @.js@ file, as @node16@/@nodenext@
-- module resolution requires (and @bundler@ accepts).
emitDts :: Api -> Text
emitDts api =
  T.unlines $
    [ header api
    , ""
    , "import type * as $rt from \"./ghc_wasm_bindgen_internal.js\";"
    , ""
    , "export { HaskellError, type Either } from \"./ghc_wasm_bindgen_internal.js\";"
    , ""
    ]
      ++ 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