{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}

-- | JavaScript interpreter
--
-- See Note [The JS interpreter]
--
module GHC.Runtime.Interpreter.JS
  ( spawnJSInterp
  , jsLinkRts
  , jsLinkInterp
  , jsLinkObject
  , jsLinkObjects
  , jsLoadFile
  , jsRunServer
  -- * Reexported for convenience
  , mkExportedModFuns
  )
where

import GHC.Prelude
import GHC.Runtime.Interpreter.Types
import GHC.Runtime.Interpreter.Process
import GHC.Runtime.Utils
import GHCi.Message

import GHC.StgToJS.Linker.Types
import GHC.StgToJS.Linker.Linker
import GHC.StgToJS.Types
import GHC.StgToJS.Object

import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.State

import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Utils.Panic
import GHC.Utils.Error (logInfo)
import GHC.Utils.Outputable (text)
import GHC.Data.FastString
import GHC.Types.Unique.FM

import Control.Concurrent
import Control.Monad

import System.Process
import System.IO
import System.FilePath

import Data.IORef
import qualified Data.Set    as Set
import qualified Data.ByteString as B

import Foreign.C.String


-- Note [The JS interpreter]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- The JS interpreter works as follows:
--
-- ghc-interp.js is a simple JS script used to bootstrap the external
-- interpreter server (iserv) that is written in Haskell. This script waits for
-- commands on stdin:
--
--      LOAD foo.js
--
--        load a JS file in the current JS environment
--
--      RUN_SERVER ghci_unit_id
--
--        execute h$main(h$ghci_unit_idZCGHCiziServerzidefaultServer),
--        the entry point of the interpreter server
--
-- On the GHC side, when we need the interpreter we do the following:
--
-- 1. spawn nodejs with $topdir/ghc-interp.js script
-- 2. link the JS rts and send a LOAD command to load it
-- 3. link iserv (i.e. use GHCi.Server.defaultServer as root) and LOAD it
-- 4. send a RUN_SERVER command to execute the JS iserv
--
-- From this moment on, everything happens as with the native iserv, using a
-- pipe for communication, with the following differences:
--
--  - the JS iserv only supports the LoadObj linking command which has been
--  repurposed to load a JS source file. The JS iserv doesn't deal with
--  libraries (.a) and with object files (.o). The linker state is maintained on
--  the GHC side and GHC only sends the appropriate chunks of JS code to link.
--
--  - the JS iserv doesn't support ByteCode (i.e. it doesn't support CreateBCOs
--  messages). JS iserv clients should use the usual JS compilation pipeline and
--  send JS code instead. See GHC.Driver.Main.hscCompileCoreExpr for an example.
--
-- GHC keeps track of JS blocks (JS unit of linking corresponding to top-level
-- binding groups) that have already been linked by the JS interpreter. It only
-- links new ones when necessary.
--
-- Note that the JS interpreter isn't subject to staging issues: we can use it
-- in a Stage1 GHC.
--

---------------------------------------------------------
-- Running node
---------------------------------------------------------

-- | Start NodeJS interactively with "ghc-interp.js" script loaded in
startTHRunnerProcess :: FilePath -> NodeJsSettings -> IO (Handle,InterpProcess)
startTHRunnerProcess :: FilePath -> NodeJsSettings -> IO (Handle, InterpProcess)
startTHRunnerProcess FilePath
interp_js NodeJsSettings
settings = do
  interp_in <- Handle -> IO (IORef Handle)
forall a. a -> IO (IORef a)
newIORef Handle
forall a. HasCallStack => a
undefined

  let createProc CreateProcess
cp = do
          let cp' :: CreateProcess
cp' = CreateProcess
cp
                      { std_in  = CreatePipe
                      , std_out = Inherit
                      , std_err = Inherit
                      }
          (mb_in, _mb_out, _mb_err, hdl) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp'
          -- we can't directly return stdin for the process given the current
          -- implementation of runWithPipes. So we just use an IORef for this...
          case mb_in of
            Maybe Handle
Nothing -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
panic FilePath
"startTHRunnerProcess: expected stdin for interpreter"
            Just Handle
i  -> IORef Handle -> Handle -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Handle
interp_in Handle
i
          return hdl

  (hdl, rh, wh) <- runWithPipes createProc (nodeProgram settings)
                                           [interp_js]
                                           (nodeExtraArgs settings)
  std_in <- readIORef interp_in

  lo_ref <- newIORef Nothing
  let pipe = Pipe { pipeRead :: Handle
pipeRead = Handle
rh, pipeWrite :: Handle
pipeWrite = Handle
wh, pipeLeftovers :: IORef (Maybe ByteString)
pipeLeftovers = IORef (Maybe ByteString)
lo_ref }
  let proc = InterpProcess
              { interpHandle :: ProcessHandle
interpHandle = ProcessHandle
hdl
              , interpPipe :: Pipe
interpPipe   = Pipe
pipe
              }
  pure (std_in, proc)

-- | Spawn a JS interpreter
--
-- Run NodeJS with "ghc-interp.js" loaded in. Then load GHCi.Server and its deps
-- (including the rts) and run GHCi.Server.defaultServer.
spawnJSInterp :: JSInterpConfig -> IO (ExtInterpInstance JSInterpExtra)
spawnJSInterp :: JSInterpConfig -> IO (ExtInterpInstance JSInterpExtra)
spawnJSInterp JSInterpConfig
cfg = do
  let logger :: Logger
logger= JSInterpConfig -> Logger
jsInterpLogger JSInterpConfig
cfg
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Logger -> SDoc -> IO ()
logInfo Logger
logger (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Spawning JS interpreter")

  let tmpfs :: TmpFs
tmpfs        = JSInterpConfig -> TmpFs
jsInterpTmpFs JSInterpConfig
cfg
      tmp_dir :: TempDir
tmp_dir      = JSInterpConfig -> TempDir
jsInterpTmpDir JSInterpConfig
cfg
      logger :: Logger
logger       = JSInterpConfig -> Logger
jsInterpLogger JSInterpConfig
cfg
      codegen_cfg :: StgToJSConfig
codegen_cfg  = JSInterpConfig -> StgToJSConfig
jsInterpCodegenCfg JSInterpConfig
cfg
      unit_env :: UnitEnv
unit_env     = JSInterpConfig -> UnitEnv
jsInterpUnitEnv JSInterpConfig
cfg
      finder_opts :: FinderOpts
finder_opts  = JSInterpConfig -> FinderOpts
jsInterpFinderOpts JSInterpConfig
cfg
      finder_cache :: FinderCache
finder_cache = JSInterpConfig -> FinderCache
jsInterpFinderCache JSInterpConfig
cfg

  (std_in, proc) <- FilePath -> NodeJsSettings -> IO (Handle, InterpProcess)
startTHRunnerProcess (JSInterpConfig -> FilePath
jsInterpScript JSInterpConfig
cfg) (JSInterpConfig -> NodeJsSettings
jsInterpNodeConfig JSInterpConfig
cfg)

  js_state <- newMVar (JSState
                { jsLinkState     = emptyLinkPlan
                , jsServerStarted = False
                })

  -- get the unit-id of the ghci package. We need this to load the
  -- interpreter code.
  ghci_unit_id <- case lookupPackageName (ue_units unit_env) (PackageName (fsLit "ghci")) of
    Maybe UnitId
Nothing -> FilePath -> IO UnitId
forall a. FilePath -> IO a
cmdLineErrorIO FilePath
"JS interpreter: couldn't find \"ghci\" package"
    Just UnitId
i  -> UnitId -> IO UnitId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnitId
i

  let extra = JSInterpExtra
        { instStdIn :: Handle
instStdIn        = Handle
std_in
        , instJSState :: MVar JSState
instJSState      = MVar JSState
js_state
        , instFinderCache :: FinderCache
instFinderCache  = FinderCache
finder_cache
        , instFinderOpts :: FinderOpts
instFinderOpts   = FinderOpts
finder_opts
        , instGhciUnitId :: UnitId
instGhciUnitId   = UnitId
ghci_unit_id
        }

  pending_frees <- newMVar []
  lookup_cache  <- newMVar emptyUFM
  let inst = ExtInterpInstance
        { instProcess :: InterpProcess
instProcess           = InterpProcess
proc
        , instPendingFrees :: MVar [HValueRef]
instPendingFrees      = MVar [HValueRef]
pending_frees
        , instLookupSymbolCache :: MVar (UniqFM FastString (Ptr ()))
instLookupSymbolCache = MVar (UniqFM FastString (Ptr ()))
lookup_cache
        , instExtra :: JSInterpExtra
instExtra             = JSInterpExtra
extra
        }

  -- TODO: to support incremental linking of wasm modules (e.g. produced from C
  -- sources), we should:
  --
  -- 1. link the emcc rts without trimming dead code as we don't know what might
  -- be needed later by the Wasm modules we will dynamically load (cf
  -- -sMAIN_MODULE).
  -- 2. make the RUN_SERVER command wait for the emcc rts to be loaded.
  -- 3. link wasm modules with -sSIDE_MODULE
  -- 4. add a new command to load side modules with Emscripten's dlopen
  --
  -- cf https://emscripten.org/docs/compiling/Dynamic-Linking.html

  -- link rts and its deps
  jsLinkRts logger tmpfs tmp_dir codegen_cfg unit_env inst

  -- link interpreter and its deps
  jsLinkInterp logger tmpfs tmp_dir codegen_cfg unit_env inst

  -- run interpreter main loop
  jsRunServer inst

  pure inst



---------------------------------------------------------
-- Interpreter commands
---------------------------------------------------------

-- | Link JS RTS
jsLinkRts :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO ()
jsLinkRts :: Logger
-> TmpFs
-> TempDir
-> StgToJSConfig
-> UnitEnv
-> ExtInterpInstance JSInterpExtra
-> IO ()
jsLinkRts Logger
logger TmpFs
tmpfs TempDir
tmp_dir StgToJSConfig
cfg UnitEnv
unit_env ExtInterpInstance JSInterpExtra
inst = do
  let link_cfg :: JSLinkConfig
link_cfg = JSLinkConfig
        { lcNoStats :: Bool
lcNoStats         = Bool
True  -- we don't need the stats
        , lcNoRts :: Bool
lcNoRts           = Bool
False -- we need the RTS
        , lcCombineAll :: Bool
lcCombineAll      = Bool
False -- we don't need the combined all.js, we'll link each part independently below
        , lcForeignRefs :: Bool
lcForeignRefs     = Bool
False -- we don't need foreign references
        , lcNoJSExecutables :: Bool
lcNoJSExecutables = Bool
True  -- we don't need executables
        , lcNoHsMain :: Bool
lcNoHsMain        = Bool
True  -- nor HsMain
        , lcForceEmccRts :: Bool
lcForceEmccRts    = Bool
False -- nor the emcc rts
        , lcLinkCsources :: Bool
lcLinkCsources    = Bool
False -- we know that there are no C sources to load for the RTS
        }

  -- link the RTS and its dependencies (things it uses from `base`, etc.)
  let link_spec :: LinkSpec
link_spec = LinkSpec
        { lks_unit_ids :: [UnitId]
lks_unit_ids        = [UnitId
rtsUnitId, UnitId
ghcInternalUnitId, UnitId
primUnitId]
        , lks_obj_root_filter :: ExportedFun -> Bool
lks_obj_root_filter = Bool -> ExportedFun -> Bool
forall a b. a -> b -> a
const Bool
False
        , lks_extra_roots :: Set ExportedFun
lks_extra_roots     = Set ExportedFun
forall a. Monoid a => a
mempty
        , lks_objs_hs :: [FilePath]
lks_objs_hs         = [FilePath]
forall a. Monoid a => a
mempty
        , lks_objs_js :: [FilePath]
lks_objs_js         = [FilePath]
forall a. Monoid a => a
mempty
        , lks_objs_cc :: [FilePath]
lks_objs_cc         = [FilePath]
forall a. Monoid a => a
mempty
        }

  let finder_opts :: FinderOpts
finder_opts  = JSInterpExtra -> FinderOpts
instFinderOpts (ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst)
      finder_cache :: FinderCache
finder_cache = JSInterpExtra -> FinderCache
instFinderCache (ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst)

  ar_cache <- IO ArchiveCache
newArchiveCache
  link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache
  jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan

-- | Link JS interpreter
jsLinkInterp :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO ()
jsLinkInterp :: Logger
-> TmpFs
-> TempDir
-> StgToJSConfig
-> UnitEnv
-> ExtInterpInstance JSInterpExtra
-> IO ()
jsLinkInterp Logger
logger TmpFs
tmpfs TempDir
tmp_dir StgToJSConfig
cfg UnitEnv
unit_env ExtInterpInstance JSInterpExtra
inst = do

  let link_cfg :: JSLinkConfig
link_cfg = JSLinkConfig
        { lcNoStats :: Bool
lcNoStats         = Bool
True  -- we don't need the stats
        , lcNoRts :: Bool
lcNoRts           = Bool
True  -- we don't need the RTS
        , lcCombineAll :: Bool
lcCombineAll      = Bool
False -- we don't need the combined all.js, we'll link each part independently below
        , lcForeignRefs :: Bool
lcForeignRefs     = Bool
False -- we don't need foreign references
        , lcNoJSExecutables :: Bool
lcNoJSExecutables = Bool
True  -- we don't need executables
        , lcNoHsMain :: Bool
lcNoHsMain        = Bool
True  -- nor HsMain
        , lcForceEmccRts :: Bool
lcForceEmccRts    = Bool
False -- nor the emcc rts
        , lcLinkCsources :: Bool
lcLinkCsources    = Bool
True  -- enable C sources, if any
        }

  let is_root :: p -> Bool
is_root p
_ = Bool
True -- FIXME: we shouldn't consider every function as a root

  let ghci_unit_id :: UnitId
ghci_unit_id = JSInterpExtra -> UnitId
instGhciUnitId (ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst)

  -- compute unit dependencies of ghc_unit_id
  let unit_map :: UnitInfoMap
unit_map = UnitState -> UnitInfoMap
unitInfoMap (HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units UnitEnv
unit_env)
  dep_units <- MaybeErr UnitErr [UnitId] -> IO [UnitId]
forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (MaybeErr UnitErr [UnitId] -> IO [UnitId])
-> MaybeErr UnitErr [UnitId] -> IO [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitInfoMap
-> [(UnitId, Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
closeUnitDeps UnitInfoMap
unit_map [(UnitId
ghci_unit_id,Maybe UnitId
forall a. Maybe a
Nothing)]
  let units = [UnitId]
dep_units [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId
ghci_unit_id]

  -- indicate that our root function is GHCi.Server.defaultServer
  let root_deps = [ExportedFun] -> Set ExportedFun
forall a. Ord a => [a] -> Set a
Set.fromList ([ExportedFun] -> Set ExportedFun)
-> [ExportedFun] -> Set ExportedFun
forall a b. (a -> b) -> a -> b
$ UnitId -> FastString -> [FastString] -> [ExportedFun]
mkExportedFuns UnitId
ghci_unit_id (FilePath -> FastString
fsLit FilePath
"GHCi.Server") [FilePath -> FastString
fsLit FilePath
"defaultServer"]

  -- link the interpreter and its dependencies
  let link_spec = LinkSpec
        { lks_unit_ids :: [UnitId]
lks_unit_ids        = [UnitId]
units
        , lks_obj_root_filter :: ExportedFun -> Bool
lks_obj_root_filter = ExportedFun -> Bool
forall {p}. p -> Bool
is_root
        , lks_extra_roots :: Set ExportedFun
lks_extra_roots     = Set ExportedFun
root_deps
        , lks_objs_hs :: [FilePath]
lks_objs_hs         = [FilePath]
forall a. Monoid a => a
mempty
        , lks_objs_js :: [FilePath]
lks_objs_js         = [FilePath]
forall a. Monoid a => a
mempty
        , lks_objs_cc :: [FilePath]
lks_objs_cc         = [FilePath]
forall a. Monoid a => a
mempty
        }

  let finder_cache = JSInterpExtra -> FinderCache
instFinderCache (ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst)
      finder_opts  = JSInterpExtra -> FinderOpts
instFinderOpts (ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst)

  ar_cache <- newArchiveCache
  link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache
  jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan


-- | Link object files
jsLinkObjects :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> [FilePath] -> (ExportedFun -> Bool) -> IO ()
jsLinkObjects :: Logger
-> TmpFs
-> TempDir
-> StgToJSConfig
-> UnitEnv
-> ExtInterpInstance JSInterpExtra
-> [FilePath]
-> (ExportedFun -> Bool)
-> IO ()
jsLinkObjects Logger
logger TmpFs
tmpfs TempDir
tmp_dir StgToJSConfig
cfg UnitEnv
unit_env ExtInterpInstance JSInterpExtra
inst [FilePath]
objs ExportedFun -> Bool
is_root = do
  let link_cfg :: JSLinkConfig
link_cfg = JSLinkConfig
        { lcNoStats :: Bool
lcNoStats         = Bool
True  -- we don't need the stats
        , lcNoRts :: Bool
lcNoRts           = Bool
True  -- we don't need the RTS (already linked)
        , lcCombineAll :: Bool
lcCombineAll      = Bool
False -- we don't need the combined all.js, we'll link each part independently below
        , lcForeignRefs :: Bool
lcForeignRefs     = Bool
False -- we don't need foreign references
        , lcNoJSExecutables :: Bool
lcNoJSExecutables = Bool
True  -- we don't need executables
        , lcNoHsMain :: Bool
lcNoHsMain        = Bool
True  -- nor HsMain
        , lcForceEmccRts :: Bool
lcForceEmccRts    = Bool
False -- nor the emcc rts
        , lcLinkCsources :: Bool
lcLinkCsources    = Bool
True  -- enable C sources, if any
        }

  let units :: [UnitId]
units = UnitState -> [UnitId]
preloadUnits (HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units UnitEnv
unit_env)
              [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId
thUnitId] -- don't forget TH which is an implicit dep

  -- compute dependencies
  let link_spec :: LinkSpec
link_spec = LinkSpec
        { lks_unit_ids :: [UnitId]
lks_unit_ids        = [UnitId]
units
        , lks_obj_root_filter :: ExportedFun -> Bool
lks_obj_root_filter = ExportedFun -> Bool
is_root
        , lks_extra_roots :: Set ExportedFun
lks_extra_roots     = Set ExportedFun
forall a. Monoid a => a
mempty
        , lks_objs_hs :: [FilePath]
lks_objs_hs         = [FilePath]
objs
        , lks_objs_js :: [FilePath]
lks_objs_js         = [FilePath]
forall a. Monoid a => a
mempty
        , lks_objs_cc :: [FilePath]
lks_objs_cc         = [FilePath]
forall a. Monoid a => a
mempty
        }

  let finder_opts :: FinderOpts
finder_opts  = JSInterpExtra -> FinderOpts
instFinderOpts (ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst)
      finder_cache :: FinderCache
finder_cache = JSInterpExtra -> FinderCache
instFinderCache (ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst)

  ar_cache <- IO ArchiveCache
newArchiveCache
  link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache
  jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan



-- | Link an object file using the given functions as roots
jsLinkObject :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> FilePath -> [ExportedFun] -> IO ()
jsLinkObject :: Logger
-> TmpFs
-> TempDir
-> StgToJSConfig
-> UnitEnv
-> ExtInterpInstance JSInterpExtra
-> FilePath
-> [ExportedFun]
-> IO ()
jsLinkObject Logger
logger TmpFs
tmpfs TempDir
tmp_dir StgToJSConfig
cfg UnitEnv
unit_env ExtInterpInstance JSInterpExtra
inst FilePath
obj [ExportedFun]
roots = do
  let is_root :: ExportedFun -> Bool
is_root ExportedFun
f = ExportedFun -> Set ExportedFun -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ExportedFun
f ([ExportedFun] -> Set ExportedFun
forall a. Ord a => [a] -> Set a
Set.fromList [ExportedFun]
roots)
  let objs :: [FilePath]
objs      = [FilePath
obj]
  Logger
-> TmpFs
-> TempDir
-> StgToJSConfig
-> UnitEnv
-> ExtInterpInstance JSInterpExtra
-> [FilePath]
-> (ExportedFun -> Bool)
-> IO ()
jsLinkObjects Logger
logger TmpFs
tmpfs TempDir
tmp_dir StgToJSConfig
cfg UnitEnv
unit_env ExtInterpInstance JSInterpExtra
inst [FilePath]
objs ExportedFun -> Bool
is_root


-- | Link the given link plan
--
-- Perform incremental linking by removing what is already linked from the plan
jsLinkPlan :: Logger -> TmpFs -> TempDir -> ArchiveCache -> JSLinkConfig -> StgToJSConfig -> ExtInterpInstance JSInterpExtra -> LinkPlan -> IO ()
jsLinkPlan :: Logger
-> TmpFs
-> TempDir
-> ArchiveCache
-> JSLinkConfig
-> StgToJSConfig
-> ExtInterpInstance JSInterpExtra
-> LinkPlan
-> IO ()
jsLinkPlan Logger
logger TmpFs
tmpfs TempDir
tmp_dir ArchiveCache
ar_cache JSLinkConfig
link_cfg StgToJSConfig
cfg ExtInterpInstance JSInterpExtra
inst LinkPlan
link_plan = do
  ----------------------------------------------------------------
  -- Get already linked stuff and compute incremental plan
  ----------------------------------------------------------------

  old_plan <- JSState -> LinkPlan
jsLinkState (JSState -> LinkPlan) -> IO JSState -> IO LinkPlan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar JSState -> IO JSState
forall a. MVar a -> IO a
readMVar (JSInterpExtra -> MVar JSState
instJSState (ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst))

  -- compute new plan discarding what's already linked
  let (diff_plan, total_plan) = incrementLinkPlan old_plan link_plan

  ----------------------------------------------------------------
  -- Generate JS code for the incremental plan
  ----------------------------------------------------------------

  tmp_out <- newTempSubDir logger tmpfs tmp_dir
  void $ jsLink link_cfg cfg logger tmpfs ar_cache tmp_out diff_plan

  -- Code has been linked into the following files:
  --  - generated rts from tmp_out/rts.js (depends on link options)
  --  - raw js files from tmp_out/lib.js
  --  - Haskell generated JS from tmp_out/out.js

  -- We need to combine at least rts.js and lib.js for the RTS because they
  -- depend on each other. We might as well combine them all, so that's what we
  -- do.
  let filenames
        | JSLinkConfig -> Bool
lcNoRts JSLinkConfig
link_cfg = [FilePath
"lib.js", FilePath
"out.js"]
        | Bool
otherwise        = [FilePath
"rts.js", FilePath
"lib.js", FilePath
"out.js"]
  let files = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
tmp_out FilePath -> FilePath -> FilePath
</>) [FilePath]
filenames
  let all_js = FilePath
tmp_out FilePath -> FilePath -> FilePath
</> FilePath
"all.js"
  let all_files = FilePath
all_js FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
files
  withBinaryFile all_js WriteMode $ \Handle
h -> do
    let cpy :: FilePath -> IO ()
cpy FilePath
i = FilePath -> IO ByteString
B.readFile FilePath
i IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> ByteString -> IO ()
B.hPut Handle
h
    (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
cpy [FilePath]
files

  -- add files to clean
  addFilesToClean tmpfs TFL_CurrentModule all_files

  ----------------------------------------------------------------
  -- Link JS code
  ----------------------------------------------------------------

  -- linking JS code depends on the phase we're in:
  -- - during in the initialization phase, we send a LoadFile message to the
  --   JS server;
  -- - once the Haskell server is started, we send a LoadObj message to the
  --   Haskell server.
  server_started <- jsServerStarted <$> readMVar (instJSState (instExtra inst))
  if server_started
    then sendMessageNoResponse inst $ LoadObj all_js
    else jsLoadFile            inst all_js

  ----------------------------------------------------------------
  -- update linker state
  ----------------------------------------------------------------
  modifyMVar_ (instJSState (instExtra inst)) $ \JSState
state -> JSState -> IO JSState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSState
state { jsLinkState = total_plan }


-- | Send a command to the JS interpreter
jsSendCommand :: ExtInterpInstance JSInterpExtra -> String -> IO ()
jsSendCommand :: ExtInterpInstance JSInterpExtra -> FilePath -> IO ()
jsSendCommand ExtInterpInstance JSInterpExtra
inst FilePath
cmd = FilePath -> IO ()
send_cmd FilePath
cmd
  where
    extra :: JSInterpExtra
extra      = ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst
    handle :: Handle
handle     = JSInterpExtra -> Handle
instStdIn JSInterpExtra
extra
    send_cmd :: FilePath -> IO ()
send_cmd FilePath
s = do
      FilePath -> (CStringLen -> IO ()) -> IO ()
forall a. FilePath -> (CStringLen -> IO a) -> IO a
withCStringLen FilePath
s \(Ptr CChar
p,Int
n) -> Handle -> Ptr CChar -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
handle Ptr CChar
p Int
n
      Handle -> IO ()
hFlush Handle
handle

-- | Load a JS file in the interpreter
jsLoadFile :: ExtInterpInstance JSInterpExtra -> FilePath -> IO ()
jsLoadFile :: ExtInterpInstance JSInterpExtra -> FilePath -> IO ()
jsLoadFile ExtInterpInstance JSInterpExtra
inst FilePath
path = ExtInterpInstance JSInterpExtra -> FilePath -> IO ()
jsSendCommand ExtInterpInstance JSInterpExtra
inst (FilePath
"LOAD " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n")

-- | Run JS server
jsRunServer :: ExtInterpInstance JSInterpExtra -> IO ()
jsRunServer :: ExtInterpInstance JSInterpExtra -> IO ()
jsRunServer ExtInterpInstance JSInterpExtra
inst = do
  let ghci_unit_id :: UnitId
ghci_unit_id = JSInterpExtra -> UnitId
instGhciUnitId (ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst)
  let zghci_unit_id :: FilePath
zghci_unit_id = FastZString -> FilePath
zString (FastString -> FastZString
zEncodeFS (UnitId -> FastString
unitIdFS UnitId
ghci_unit_id))

  -- Run `GHCi.Server.defaultServer`
  ExtInterpInstance JSInterpExtra -> FilePath -> IO ()
jsSendCommand ExtInterpInstance JSInterpExtra
inst (FilePath
"RUN_SERVER " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
zghci_unit_id FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n")

  -- indicate that the Haskell server is now started
  MVar JSState -> (JSState -> IO JSState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (JSInterpExtra -> MVar JSState
instJSState (ExtInterpInstance JSInterpExtra -> JSInterpExtra
forall c. ExtInterpInstance c -> c
instExtra ExtInterpInstance JSInterpExtra
inst)) ((JSState -> IO JSState) -> IO ())
-> (JSState -> IO JSState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \JSState
state -> JSState -> IO JSState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSState
state { jsServerStarted = True }