{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE LambdaCase #-}

{-# OPTIONS_GHC -Wno-orphans #-} -- for Ident's Binary instance

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Linker.Types
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
--                Luite Stegeman <luite.stegeman@iohk.io>
--                Sylvain Henry  <sylvain.henry@iohk.io>
--                Josh Meredith  <josh.meredith@iohk.io>
-- Stability   :  experimental
--
-----------------------------------------------------------------------------

module GHC.StgToJS.Linker.Types
  ( GhcjsEnv (..)
  , newGhcjsEnv
  , JSLinkConfig (..)
  , defaultJSLinkConfig
  , generateAllJs
  , LinkedObj (..)
  , LinkableUnit
  )
where

import GHC.StgToJS.Object

import GHC.Unit.Types
import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr)

import Data.Map.Strict      (Map)
import qualified Data.Map.Strict as M
import Data.Set             (Set)

import Control.Concurrent.MVar

import System.IO

import Prelude

--------------------------------------------------------------------------------
-- Linker Config
--------------------------------------------------------------------------------

data JSLinkConfig = JSLinkConfig
  { JSLinkConfig -> Bool
lcNoJSExecutables    :: Bool
  , JSLinkConfig -> Bool
lcNoHsMain           :: Bool
  , JSLinkConfig -> Bool
lcOnlyOut            :: Bool
  , JSLinkConfig -> Bool
lcNoRts              :: Bool
  , JSLinkConfig -> Bool
lcNoStats            :: Bool
  }

-- | we generate a runnable all.js only if we link a complete application,
--   no incremental linking and no skipped parts
generateAllJs :: JSLinkConfig -> Bool
generateAllJs :: JSLinkConfig -> Bool
generateAllJs JSLinkConfig
s = Bool -> Bool
not (JSLinkConfig -> Bool
lcOnlyOut JSLinkConfig
s) Bool -> Bool -> Bool
&& Bool -> Bool
not (JSLinkConfig -> Bool
lcNoRts JSLinkConfig
s)

defaultJSLinkConfig :: JSLinkConfig
defaultJSLinkConfig :: JSLinkConfig
defaultJSLinkConfig = JSLinkConfig
  { lcNoJSExecutables :: Bool
lcNoJSExecutables = Bool
False
  , lcNoHsMain :: Bool
lcNoHsMain        = Bool
False
  , lcOnlyOut :: Bool
lcOnlyOut         = Bool
False
  , lcNoRts :: Bool
lcNoRts           = Bool
False
  , lcNoStats :: Bool
lcNoStats         = Bool
False
  }

--------------------------------------------------------------------------------
-- Linker Environment
--------------------------------------------------------------------------------

-- | A @LinkableUnit@ is a pair of a module and the index of the block in the
-- object file
type LinkableUnit = (Module, Int)

-- | An object file that's either already in memory (with name) or on disk
data LinkedObj
  = ObjFile   FilePath      -- ^ load from this file
  | ObjLoaded String Object -- ^ already loaded: description and payload

instance Outputable LinkedObj where
  ppr :: LinkedObj -> SDoc
ppr = \case
    ObjFile FilePath
fp    -> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"ObjFile", FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
fp]
    ObjLoaded FilePath
s Object
o -> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"ObjLoaded", FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
s, ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Object -> ModuleName
objModuleName Object
o)]

data GhcjsEnv = GhcjsEnv
  { GhcjsEnv
-> MVar
     (Map
        (Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]))
linkerArchiveDeps :: MVar (Map (Set FilePath)
                                   (Map Module (Deps, DepsLocation)
                                   , [LinkableUnit]
                                   )
                              )
  }

-- | return a fresh @GhcjsEnv@
newGhcjsEnv :: IO GhcjsEnv
newGhcjsEnv :: IO GhcjsEnv
newGhcjsEnv = MVar
  (Map
     (Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]))
-> GhcjsEnv
GhcjsEnv (MVar
   (Map
      (Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit]))
 -> GhcjsEnv)
-> IO
     (MVar
        (Map
           (Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])))
-> IO GhcjsEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map
  (Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
-> IO
     (MVar
        (Map
           (Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])))
forall a. a -> IO (MVar a)
newMVar Map
  (Set FilePath) (Map Module (Deps, DepsLocation), [LinkableUnit])
forall k a. Map k a
M.empty