EmitHaskell.hs

-- | 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"