{-# 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
  IORef Handle
interp_in <- Handle -> IO (IORef Handle)
forall a. a -> IO (IORef a)
newIORef Handle
forall a. HasCallStack => a
undefined

  let createProc :: CreateProcess -> IO ProcessHandle
createProc CreateProcess
cp = do
          let cp' :: CreateProcess
cp' = CreateProcess
cp
                      { std_in  = CreatePipe
                      , std_out = Inherit
                      , std_err = Inherit
                      }
          (Maybe Handle
mb_in, Maybe Handle
_mb_out, Maybe Handle
_mb_err, ProcessHandle
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 Maybe Handle
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
          ProcessHandle -> IO ProcessHandle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
hdl

  (ProcessHandle
hdl, Handle
rh, Handle
wh) <- (CreateProcess -> IO ProcessHandle)
-> FilePath
-> [FilePath]
-> [FilePath]
-> IO (ProcessHandle, Handle, Handle)
runWithPipes CreateProcess -> IO ProcessHandle
createProc (NodeJsSettings -> FilePath
nodeProgram NodeJsSettings
settings)
                                           [FilePath
interp_js]
                                           (NodeJsSettings -> [FilePath]
nodeExtraArgs NodeJsSettings
settings)
  Handle
std_in <- IORef Handle -> IO Handle
forall a. IORef a -> IO a
readIORef IORef Handle
interp_in

  IORef (Maybe ByteString)
lo_ref <- Maybe ByteString -> IO (IORef (Maybe ByteString))
forall a. a -> IO (IORef a)
newIORef Maybe ByteString
forall a. Maybe a
Nothing
  let pipe :: Pipe
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
proc = InterpProcess
              { interpHandle :: ProcessHandle
interpHandle = ProcessHandle
hdl
              , interpPipe :: Pipe
interpPipe   = Pipe
pipe
              }
  (Handle, InterpProcess) -> IO (Handle, InterpProcess)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Handle
std_in, InterpProcess
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

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

  MVar JSState
js_state <- JSState -> IO (MVar JSState)
forall a. a -> IO (MVar a)
newMVar (JSState
                { jsLinkState :: LinkPlan
jsLinkState     = LinkPlan
emptyLinkPlan
                , jsServerStarted :: Bool
jsServerStarted = Bool
False
                })

  -- get the unit-id of the ghci package. We need this to load the
  -- interpreter code.
  UnitId
ghci_unit_id <- case UnitState -> PackageName -> Maybe UnitId
lookupPackageName (HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units UnitEnv
unit_env) (FastString -> PackageName
PackageName (FilePath -> FastString
fsLit FilePath
"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
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
        }

  MVar [HValueRef]
pending_frees <- [HValueRef] -> IO (MVar [HValueRef])
forall a. a -> IO (MVar a)
newMVar []
  MVar (UniqFM FastString (Ptr ()))
lookup_cache  <- UniqFM FastString (Ptr ())
-> IO (MVar (UniqFM FastString (Ptr ())))
forall a. a -> IO (MVar a)
newMVar UniqFM FastString (Ptr ())
forall key elt. UniqFM key elt
emptyUFM
  let inst :: ExtInterpInstance JSInterpExtra
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
        }

  -- link rts and its deps
  Logger
-> TmpFs
-> TempDir
-> StgToJSConfig
-> UnitEnv
-> ExtInterpInstance JSInterpExtra
-> IO ()
jsLinkRts Logger
logger TmpFs
tmpfs TempDir
tmp_dir StgToJSConfig
codegen_cfg UnitEnv
unit_env ExtInterpInstance JSInterpExtra
inst

  -- link interpreter and its deps
  Logger
-> TmpFs
-> TempDir
-> StgToJSConfig
-> UnitEnv
-> ExtInterpInstance JSInterpExtra
-> IO ()
jsLinkInterp Logger
logger TmpFs
tmpfs TempDir
tmp_dir StgToJSConfig
codegen_cfg UnitEnv
unit_env ExtInterpInstance JSInterpExtra
inst

  -- run interpreter main loop
  ExtInterpInstance JSInterpExtra -> IO ()
jsRunServer ExtInterpInstance JSInterpExtra
inst

  ExtInterpInstance JSInterpExtra
-> IO (ExtInterpInstance JSInterpExtra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtInterpInstance JSInterpExtra
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
        }

  -- 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
baseUnitId, UnitId
primUnitId]
        , lks_obj_files :: [LinkedObj]
lks_obj_files       = [LinkedObj]
forall a. Monoid a => a
mempty
        , 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_extra_js :: [FilePath]
lks_extra_js        = [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)

  LinkPlan
link_plan <- StgToJSConfig
-> UnitEnv -> LinkSpec -> FinderOpts -> FinderCache -> IO LinkPlan
computeLinkDependencies StgToJSConfig
cfg UnitEnv
unit_env LinkSpec
link_spec FinderOpts
finder_opts FinderCache
finder_cache
  Logger
-> TmpFs
-> TempDir
-> JSLinkConfig
-> StgToJSConfig
-> ExtInterpInstance JSInterpExtra
-> LinkPlan
-> IO ()
jsLinkPlan Logger
logger TmpFs
tmpfs TempDir
tmp_dir JSLinkConfig
link_cfg StgToJSConfig
cfg ExtInterpInstance JSInterpExtra
inst LinkPlan
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
        }

  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)
  [UnitId]
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]
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 :: Set ExportedFun
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
link_spec = LinkSpec
        { lks_unit_ids :: [UnitId]
lks_unit_ids        = [UnitId]
units
        , lks_obj_files :: [LinkedObj]
lks_obj_files       = [LinkedObj]
forall a. Monoid a => a
mempty
        , 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_extra_js :: [FilePath]
lks_extra_js        = [FilePath]
forall a. Monoid a => a
mempty
        }

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

  LinkPlan
link_plan <- StgToJSConfig
-> UnitEnv -> LinkSpec -> FinderOpts -> FinderCache -> IO LinkPlan
computeLinkDependencies StgToJSConfig
cfg UnitEnv
unit_env LinkSpec
link_spec FinderOpts
finder_opts FinderCache
finder_cache

  Logger
-> TmpFs
-> TempDir
-> JSLinkConfig
-> StgToJSConfig
-> ExtInterpInstance JSInterpExtra
-> LinkPlan
-> IO ()
jsLinkPlan Logger
logger TmpFs
tmpfs TempDir
tmp_dir JSLinkConfig
link_cfg StgToJSConfig
cfg ExtInterpInstance JSInterpExtra
inst LinkPlan
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
        }

  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_files :: [LinkedObj]
lks_obj_files       = (FilePath -> LinkedObj) -> [FilePath] -> [LinkedObj]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> LinkedObj
ObjFile [FilePath]
objs
        , 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_extra_js :: [FilePath]
lks_extra_js        = [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)

  LinkPlan
link_plan <- StgToJSConfig
-> UnitEnv -> LinkSpec -> FinderOpts -> FinderCache -> IO LinkPlan
computeLinkDependencies StgToJSConfig
cfg UnitEnv
unit_env LinkSpec
link_spec FinderOpts
finder_opts FinderCache
finder_cache

  -- link
  Logger
-> TmpFs
-> TempDir
-> JSLinkConfig
-> StgToJSConfig
-> ExtInterpInstance JSInterpExtra
-> LinkPlan
-> IO ()
jsLinkPlan Logger
logger TmpFs
tmpfs TempDir
tmp_dir JSLinkConfig
link_cfg StgToJSConfig
cfg ExtInterpInstance JSInterpExtra
inst LinkPlan
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 -> JSLinkConfig -> StgToJSConfig -> ExtInterpInstance JSInterpExtra -> LinkPlan -> IO ()
jsLinkPlan :: Logger
-> TmpFs
-> TempDir
-> JSLinkConfig
-> StgToJSConfig
-> ExtInterpInstance JSInterpExtra
-> LinkPlan
-> IO ()
jsLinkPlan Logger
logger TmpFs
tmpfs TempDir
tmp_dir JSLinkConfig
link_cfg StgToJSConfig
cfg ExtInterpInstance JSInterpExtra
inst LinkPlan
link_plan = do
  ----------------------------------------------------------------
  -- Get already linked stuff and compute incremental plan
  ----------------------------------------------------------------

  LinkPlan
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 (LinkPlan
diff_plan, LinkPlan
total_plan) = LinkPlan -> LinkPlan -> (LinkPlan, LinkPlan)
incrementLinkPlan LinkPlan
old_plan LinkPlan
link_plan

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

  FilePath
tmp_out <- Logger -> TmpFs -> TempDir -> IO FilePath
newTempSubDir Logger
logger TmpFs
tmpfs TempDir
tmp_dir
  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ JSLinkConfig
-> StgToJSConfig -> Logger -> FilePath -> LinkPlan -> IO ()
jsLink JSLinkConfig
link_cfg StgToJSConfig
cfg Logger
logger FilePath
tmp_out LinkPlan
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 :: [FilePath]
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]
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
all_js = FilePath
tmp_out FilePath -> FilePath -> FilePath
</> FilePath
"all.js"
  let all_files :: [FilePath]
all_files = FilePath
all_js FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
files
  FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
all_js IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
  TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
TFL_CurrentModule [FilePath]
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.
  Bool
server_started <- JSState -> Bool
jsServerStarted (JSState -> Bool) -> IO JSState -> IO Bool
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))
  if Bool
server_started
    then ExtInterpInstance JSInterpExtra -> Message () -> IO ()
forall d. ExtInterpInstance d -> Message () -> IO ()
sendMessageNoResponse ExtInterpInstance JSInterpExtra
inst (Message () -> IO ()) -> Message () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Message ()
LoadObj FilePath
all_js
    else ExtInterpInstance JSInterpExtra -> FilePath -> IO ()
jsLoadFile            ExtInterpInstance JSInterpExtra
inst FilePath
all_js

  ----------------------------------------------------------------
  -- update linker state
  ----------------------------------------------------------------
  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 { 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 }