{-# LANGUAGE CPP                        #-}
{-# LANGUAGE MagicHash                  #-}
{-# LANGUAGE UnboxedTuples              #-}
{-# LANGUAGE ForeignFunctionInterface   #-}
--
-- Copyright (C) 2004-5 Don Stewart
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
-- USA
--

-- | An interface to the GHC runtime's dynamic linker, providing runtime
-- loading and linking of Haskell object files, commonly known as
-- /plugins/.

module System.Plugins.Load (

      -- * The @LoadStatus@ type
      LoadStatus(..)

      -- * High-level interface
      , load
      , load_
      , dynload
      , pdynload
      , pdynload_
      , unload
      , unloadAll
      , reload
      , Module(..)

      -- * Low-level interface
      , initLinker      -- start it up
      , loadModule      -- load a vanilla .o
      , loadFunction    -- retrieve a function from an object
      , loadFunction_   -- retrieve a function from an object
      , loadPackageFunction
      , loadPackage     -- load a ghc library and its cbits
      , unloadPackage   -- unload a ghc library and its cbits
      , loadPackageWith -- load a pkg using the package.conf provided
      , loadShared      -- load a .so object file
      , resolveObjs     -- and resolve symbols

      , loadRawObject   -- load a bare .o. no dep chasing, no .hi file reading

      , Symbol

      , getImports

  ) where

#include "config.h"

import System.Plugins.Make             ( build )
import System.Plugins.Env
import System.Plugins.Utils
import System.Plugins.Consts           ( sysPkgSuffix, hiSuf, prefixUnderscore )
import System.Plugins.LoadTypes

-- import Language.Hi.Parser
import Encoding (zEncodeString)
import BinIface
import HscTypes

import Module (moduleName, moduleNameString)
#if MIN_VERSION_ghc(8,0,0)
#if MIN_VERSION_Cabal(2,0,0)
import Module (installedUnitIdString)
#else
import Module (unitIdString)
#endif
#elif MIN_VERSION_ghc(7,10,0)
import Module (packageKeyString)
#else
import Module (packageIdString)
#endif

import HscMain (newHscEnv)
import TcRnMonad (initTcRnIf)

import Data.Dynamic          ( fromDynamic, Dynamic )
import Data.Typeable         ( Typeable )

import Data.List                ( isSuffixOf, nub, nubBy )
import Control.Monad            ( when, filterM, liftM )
import System.Directory         ( doesFileExist, removeFile )
import Foreign.C                ( CInt(..) )
import Foreign.C.String         ( CString, withCString, peekCString )

#if !MIN_VERSION_ghc(7,2,0)
import GHC                      ( defaultCallbacks )
#else
import DynFlags                 (defaultDynFlags, initDynFlags)
import GHC.Paths                (libdir)
import SysTools                 ( initSysTools
#if MIN_VERSION_ghc(8,10,1)
                                , lazyInitLlvmConfig
#else
                                , initLlvmConfig
#endif
                                )
#endif
import GHC.Ptr                  ( Ptr(..), nullPtr )
#if !MIN_VERSION_ghc(7,4,1)
import GHC.Exts                 ( addrToHValue# )
#else
import GHC.Exts                 ( addrToAny# )
#endif

import GHC.Prim                 ( unsafeCoerce# )

#if DEBUG
import System.IO                ( hFlush, stdout )
#endif
import System.IO                ( hClose )

#if !MIN_VERSION_ghc(8,10,1)
lazyInitLlvmConfig = initLlvmConfig
#endif

ifaceModuleName :: ModIface_ phase -> String
ifaceModuleName = ModuleName -> String
moduleNameString (ModuleName -> String)
-> (ModIface_ phase -> ModuleName) -> ModIface_ phase -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName (Module -> ModuleName)
-> (ModIface_ phase -> Module) -> ModIface_ phase -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface_ phase -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module

readBinIface' :: FilePath -> IO ModIface
readBinIface' :: String -> IO ModIface
readBinIface' String
hi_path = do
    -- kludgy as hell
#if MIN_VERSION_ghc(7,2,0)
#if MIN_VERSION_ghc(8,8,1)
    Settings
mySettings <- String -> IO Settings
initSysTools (String
libdir) -- how should we really set the top dir?
    LlvmConfig
llvmConfig <- String -> IO LlvmConfig
lazyInitLlvmConfig (String
libdir)
#else
    mySettings <- initSysTools (Just libdir) -- how should we really set the top dir?
    llvmConfig <- lazyInitLlvmConfig (Just libdir)
#endif
    DynFlags
dflags <- DynFlags -> IO DynFlags
initDynFlags (Settings -> LlvmConfig -> DynFlags
defaultDynFlags Settings
mySettings LlvmConfig
llvmConfig)
    HscEnv
e <- DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags
#else
    e <- newHscEnv defaultCallbacks undefined
#endif
    Char
-> HscEnv -> Any -> Any -> TcRnIf Any Any ModIface -> IO ModIface
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf Char
'r' HscEnv
e Any
forall a. HasCallStack => a
undefined Any
forall a. HasCallStack => a
undefined (CheckHiWay
-> TraceBinIFaceReading -> String -> TcRnIf Any Any ModIface
forall a b.
CheckHiWay -> TraceBinIFaceReading -> String -> TcRnIf a b ModIface
readBinIface CheckHiWay
IgnoreHiWay TraceBinIFaceReading
QuietBinIFaceReading String
hi_path)

-- TODO need a loadPackage p package.conf :: IO () primitive

--
-- | The @LoadStatus@ type encodes the return status of functions that
-- perform dynamic loading in a type isomorphic to 'Either'. Failure
-- returns a list of error strings, success returns a reference to a
-- loaded module, and the Haskell value corresponding to the symbol that
-- was indexed.
--
data LoadStatus a
        = LoadSuccess Module a
        | LoadFailure Errors

--
-- | 'load' is the basic interface to the dynamic loader. A call to
-- 'load' imports a single object file into the caller's address space,
-- returning the value associated with the symbol requested. Libraries
-- and modules that the requested module depends upon are loaded and
-- linked in turn.
--
-- The first argument is the path to the object file to load, the second
-- argument is a list of directories to search for dependent modules.
-- The third argument is a list of paths to user-defined, but
-- unregistered, /package.conf/ files. The 'Symbol' argument is the
-- symbol name of the value you with to retrieve.
--
-- The value returned must be given an explicit type signature, or
-- provided with appropriate type constraints such that Haskell compiler
-- can determine the expected type returned by 'load', as the return
-- type is notionally polymorphic.
--
-- Example:
--
-- > do mv <- load "Plugin.o" ["api"] [] "resource"
-- >    case mv of
-- >        LoadFailure msg -> print msg
-- >        LoadSuccess _ v -> return v
--
load :: FilePath                -- ^ object file
     -> [FilePath]              -- ^ any include paths
     -> [PackageConf]           -- ^ list of package.conf paths
     -> Symbol                  -- ^ symbol to find
     -> IO (LoadStatus a)

load :: String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
obj [String]
incpaths [String]
pkgconfs String
sym = do
    CInt -> IO ()
initLinker_ (CInt -> IO ()) -> CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
0

    -- load extra package information
    (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
addPkgConf [String]
pkgconfs
    (ModIface
hif,[Module]
moduleDeps) <- String -> [String] -> IO (ModIface, [Module])
loadDepends String
obj [String]
incpaths

    -- why is this the package name?
#if DEBUG
    putStr (' ':(decode $ ifaceModuleName hif)) >> hFlush stdout
#endif

    Module
m' <- String -> Key -> IO Module
loadObject String
obj (Key -> IO Module) -> (ModIface -> Key) -> ModIface -> IO Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Key
Object (String -> Key) -> (ModIface -> String) -> ModIface -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> String
forall (phase :: ModIfacePhase). ModIface_ phase -> String
ifaceModuleName (ModIface -> IO Module) -> ModIface -> IO Module
forall a b. (a -> b) -> a -> b
$ ModIface
hif
    let m :: Module
m = Module
m' { iface :: ModIface
iface = ModIface
hif }
    IO () -> IO ()
forall a. IO a -> IO ()
resolveObjs ((Module -> IO ()) -> [Module] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Module -> IO ()
unloadAll (Module
mModule -> [Module] -> [Module]
forall a. a -> [a] -> [a]
:[Module]
moduleDeps))

#if DEBUG
    putStrLn " ... done" >> hFlush stdout
#endif
    Module -> [Module] -> IO ()
addModuleDeps Module
m' [Module]
moduleDeps
    Maybe a
v <- Module -> String -> IO (Maybe a)
forall a. Module -> String -> IO (Maybe a)
loadFunction Module
m String
sym
    LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadStatus a -> IO (LoadStatus a))
-> LoadStatus a -> IO (LoadStatus a)
forall a b. (a -> b) -> a -> b
$ case Maybe a
v of
        Maybe a
Nothing -> [String] -> LoadStatus a
forall a. [String] -> LoadStatus a
LoadFailure [String
"load: couldn't find symbol <<"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
symString -> String -> String
forall a. [a] -> [a] -> [a]
++String
">>"]
        Just a
a  -> Module -> a -> LoadStatus a
forall a. Module -> a -> LoadStatus a
LoadSuccess Module
m a
a

--
-- | Like load, but doesn't want a package.conf arg (they are rarely used)
--
load_ :: FilePath    -- ^ object file
      -> [FilePath]  -- ^ any include paths
      -> Symbol      -- ^ symbol to find
      -> IO (LoadStatus a)
load_ :: String -> [String] -> String -> IO (LoadStatus a)
load_ String
o [String]
i String
s = String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
o [String]
i [] String
s


-- | A work-around for Dynamics. The keys used to compare two TypeReps are
-- somehow not equal for the same type in hs-plugin's loaded objects.
-- Solution: implement our own dynamics...
--
-- The problem with dynload is that it requires the plugin to export
-- a value that is a Dynamic (in our case a (TypeRep,a) pair). If this
-- is not the case, we core dump. Use pdynload if you don't trust the
-- user to supply you with a Dynamic
--
dynload :: Typeable a
        => FilePath
        -> [FilePath]
        -> [PackageConf]
        -> Symbol
        -> IO (LoadStatus a)

dynload :: String -> [String] -> [String] -> String -> IO (LoadStatus a)
dynload String
obj [String]
incpaths [String]
pkgconfs String
sym = do
    LoadStatus a
s <- String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
obj [String]
incpaths [String]
pkgconfs String
sym
    case LoadStatus a
s of e :: LoadStatus a
e@(LoadFailure [String]
_)   -> LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return LoadStatus a
e
              LoadSuccess Module
m a
dyn_v -> LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadStatus a -> IO (LoadStatus a))
-> LoadStatus a -> IO (LoadStatus a)
forall a b. (a -> b) -> a -> b
$
                    case Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (a -> Dynamic
unsafeCoerce# a
dyn_v :: Dynamic) of
                        Just a
v' -> Module -> a -> LoadStatus a
forall a. Module -> a -> LoadStatus a
LoadSuccess Module
m a
v'
                        Maybe a
Nothing -> [String] -> LoadStatus a
forall a. [String] -> LoadStatus a
LoadFailure [String
"Mismatched types in interface"]

------------------------------------------------------------------------

-- |
-- The super-replacement for dynload
--
-- Use GHC at runtime so we get staged type inference, providing full
-- power dynamics, *on module interfaces only*. This is quite suitable
-- for plugins, of coures :)
--
-- TODO where does the .hc file go in the call to build() ?
--
pdynload :: FilePath                    -- ^ object to load
         -> [FilePath]                  -- ^ include paths
         -> [PackageConf]               -- ^ package confs
         -> Type                        -- ^ API type
         -> Symbol                      -- ^ symbol
         -> IO (LoadStatus a)

pdynload :: String
-> [String] -> [String] -> String -> String -> IO (LoadStatus a)
pdynload String
object [String]
incpaths [String]
pkgconfs String
ty String
sym = do
#if DEBUG
        putStr "Checking types ... " >> hFlush stdout
#endif
        ([String]
errors, Bool
success) <- String
-> [String] -> [String] -> String -> String -> IO ([String], Bool)
unify String
object [String]
incpaths [] String
ty String
sym
#if DEBUG
        putStrLn "done"
#endif
        if Bool
success
                then String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
object [String]
incpaths [String]
pkgconfs String
sym
                else LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadStatus a -> IO (LoadStatus a))
-> LoadStatus a -> IO (LoadStatus a)
forall a b. (a -> b) -> a -> b
$ [String] -> LoadStatus a
forall a. [String] -> LoadStatus a
LoadFailure [String]
errors

--
-- | Like pdynload, but you can specify extra arguments to the
-- typechecker.
--
pdynload_ :: FilePath       -- ^ object to load
          -> [FilePath]     -- ^ include paths for loading
          -> [PackageConf]  -- ^ any extra package.conf files
          -> [Arg]          -- ^ extra arguments to ghc, when typechecking
          -> Type           -- ^ expected type
          -> Symbol         -- ^ symbol to load
          -> IO (LoadStatus a)

pdynload_ :: String
-> [String]
-> [String]
-> [String]
-> String
-> String
-> IO (LoadStatus a)
pdynload_ String
object [String]
incpaths [String]
pkgconfs [String]
args String
ty String
sym = do
#if DEBUG
        putStr "Checking types ... " >> hFlush stdout
#endif
        ([String]
errors, Bool
success) <- String
-> [String] -> [String] -> String -> String -> IO ([String], Bool)
unify String
object [String]
incpaths [String]
args String
ty String
sym
#if DEBUG
        putStrLn "done"
#endif
        if Bool
success
                then String -> [String] -> [String] -> String -> IO (LoadStatus a)
forall a.
String -> [String] -> [String] -> String -> IO (LoadStatus a)
load String
object [String]
incpaths [String]
pkgconfs String
sym
                else LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadStatus a -> IO (LoadStatus a))
-> LoadStatus a -> IO (LoadStatus a)
forall a b. (a -> b) -> a -> b
$ [String] -> LoadStatus a
forall a. [String] -> LoadStatus a
LoadFailure [String]
errors

------------------------------------------------------------------------
-- | run the typechecker over the constraint file
--
-- Problem: if the user depends on a non-auto package to build the
-- module, then that package will not be in scope when we try to build
-- the module, when performing `unify'. Normally make() will handle this
-- (as it takes extra ghc args). pdynload ignores these, atm -- but it
-- shouldn't. Consider a pdynload() that accepts extra -package flags?
--
-- Also, pdynload() should accept extra in-scope modules.
-- Maybe other stuff we want to hack in here.
--
unify :: String
-> [String] -> [String] -> String -> String -> IO ([String], Bool)
unify String
obj [String]
incs [String]
args String
ty String
sym = do
        (String
tmpf,Handle
hdl)   <- IO (String, Handle)
mkTemp
        (String
tmpf1,Handle
hdl1) <- IO (String, Handle)
mkTemp  -- and send .hi file here.
        Handle -> IO ()
hClose Handle
hdl1

        let nm :: String
nm  = String -> String
mkModid (String -> String
basename String
tmpf)
            src :: String
src = String -> String -> String -> String -> String -> String
mkTest String
nm (String -> String
hierize' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
mkModid (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
hierize (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
obj)
                                ((String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String) -> (String, String) -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') String
ty) String
ty String
sym
            is :: [String]
is  = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-i"String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
incs             -- api
            i :: String
i   = String
"-i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
dirname String
obj           -- plugin

        Handle -> String -> IO ()
hWrite Handle
hdl String
src

        ([String]
e,Bool
success) <- String -> String -> [String] -> IO ([String], Bool)
build String
tmpf String
tmpf1 (String
iString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
is[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
args[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String
"-fno-code",String
"-c",String
"-ohi "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
tmpf1])
        (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
removeFile [String
tmpf,String
tmpf1]
        ([String], Bool) -> IO ([String], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
e, Bool
success)

        where
            -- fix up hierarchical names
            hierize :: String -> String
hierize []       = []
            hierize (Char
'/':String
cs) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
hierize String
cs
            hierize (Char
c:String
cs)   = Char
c    Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
hierize String
cs

            hierize' :: String -> String
hierize'[]        = []
            hierize' (Char
'\\':String
cs) = Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
hierize' String
cs
            hierize' (Char
c:String
cs)   = Char
c    Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
hierize' String
cs

mkTest :: String -> String -> String -> String -> String -> String
mkTest String
modnm String
plugin String
api String
ty String
sym =
       String
"module "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
modnm String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" where" String -> String -> String
forall a. [a] -> [a] -> [a]
++
       String
"\nimport qualified " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
plugin  String -> String -> String
forall a. [a] -> [a] -> [a]
++
       String
"\nimport qualified " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
api     String -> String -> String
forall a. [a] -> [a] -> [a]
++
       String
"{-# LINE 1 \"<typecheck>\" #-}" String -> String -> String
forall a. [a] -> [a] -> [a]
++
       String
"\n_ = "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
plugin String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"."String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sym String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" :: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ty

------------------------------------------------------------------------
{-
--
-- old version that tried to rip stuff from .hi files
--
pdynload obj incpaths pkgconfs sym ty = do
        (m, v) <- load obj incpaths pkgconfs sym
        ty'    <- mungeIface sym obj
        if ty == ty'
                then return $ Just (m, v)
                else return Nothing             -- mismatched types

   where
        -- grab the iface output from GHC. find the line relevant to our
        -- symbol. grab the string rep of the type.
        mungeIface sym o = do
                let hi = replaceSuffix o hiSuf
                (out,_) <- exec ghc ["--show-iface", hi]
                case find (\s -> (sym ++ " :: ") `isPrefixOf` s) out of
                        Nothing -> return undefined
                        Just v  -> do let v' = drop 3 $ dropWhile (/= ':') v
                                      return v'

-}

{-
--
-- a version of load the also unwraps and types a Dynamic object
--
dynload2 :: Typeable a =>
           FilePath ->
           FilePath ->
           Maybe [PackageConf] ->
           Symbol ->
           IO (Module, a)

dynload2 obj incpath pkgconfs sym = do
        (m, v) <- load obj incpath pkgconfs sym
        case fromDynamic v of
            Nothing -> panic $ "load: couldn't type "++(show v)
            Just a  -> return (m,a)
-}

------------------------------------------------------------------------
--
-- | unload a module (not its dependencies)
-- we have the dependencies, so cascaded unloading is possible
--
-- once you unload it, you can't 'load' it again, you have to 'reload'
-- it. Cause we don't unload all the dependencies
--
unload  :: Module -> IO ()
unload :: Module -> IO ()
unload Module
m = Module -> IO ()
rmModuleDeps Module
m IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Module -> IO ()
unloadObj Module
m

------------------------------------------------------------------------
--
-- | unload a module and its dependencies
-- we have the dependencies, so cascaded unloading is possible
--
unloadAll :: Module -> IO ()
unloadAll :: Module -> IO ()
unloadAll Module
m = do [Module]
moduleDeps <- Module -> IO [Module]
getModuleDeps Module
m
                 Module -> IO ()
rmModuleDeps Module
m
                 (Module -> IO ()) -> [Module] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Module -> IO ()
unloadAll [Module]
moduleDeps
                 Module -> IO ()
unload Module
m


--
-- | this will be nice for panTHeon, needs thinking about the interface
-- reload a single object file. don't care about depends, assume they
-- are loaded. (should use state to store all this)
--
-- assumes you've already done a 'load'
--
-- should factor the code
--
reload :: Module -> Symbol -> IO (LoadStatus a)
reload :: Module -> String -> IO (LoadStatus a)
reload m :: Module
m@(Module{path :: Module -> String
path = String
p, iface :: Module -> ModIface
iface = ModIface
hi}) String
sym = do
        Module -> IO ()
unloadObj Module
m     -- unload module (and delete)
#if DEBUG
        putStr ("Reloading "++(mname m)++" ... ") >> hFlush stdout
#endif
        Module
m_ <- String -> Key -> IO Module
loadObject String
p (Key -> IO Module) -> (ModIface -> Key) -> ModIface -> IO Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Key
Object (String -> Key) -> (ModIface -> String) -> ModIface -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> String
forall (phase :: ModIfacePhase). ModIface_ phase -> String
ifaceModuleName (ModIface -> IO Module) -> ModIface -> IO Module
forall a b. (a -> b) -> a -> b
$ ModIface
hi   -- load object at path p
        let m' :: Module
m' = Module
m_ { iface :: ModIface
iface = ModIface
hi }

        IO () -> IO ()
forall a. IO a -> IO ()
resolveObjs (Module -> IO ()
unloadAll Module
m)
#if DEBUG
        putStrLn "done" >> hFlush stdout
#endif
        Maybe a
v <- Module -> String -> IO (Maybe a)
forall a. Module -> String -> IO (Maybe a)
loadFunction Module
m' String
sym
        LoadStatus a -> IO (LoadStatus a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LoadStatus a -> IO (LoadStatus a))
-> LoadStatus a -> IO (LoadStatus a)
forall a b. (a -> b) -> a -> b
$ case Maybe a
v of
                Maybe a
Nothing -> [String] -> LoadStatus a
forall a. [String] -> LoadStatus a
LoadFailure [String
"load: couldn't find symbol <<"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
symString -> String -> String
forall a. [a] -> [a] -> [a]
++String
">>"]
                Just a
a  -> Module -> a -> LoadStatus a
forall a. Module -> a -> LoadStatus a
LoadSuccess Module
m' a
a

--
-- This is a stripped-down version of Andre Pang's runtime_loader,
-- which in turn is based on GHC's ghci\/ObjLinker.lhs binding
--
--  Load and unload\/Haskell modules at runtime.  This is not really
--  \'dynamic loading\', as such -- that implies that you\'re working
--  with proper shared libraries, whereas this is far more simple and
--  only loads object files.  But it achieves the same goal: you can
--  load a Haskell module at runtime, load a function from it, and run
--  the function.  I have no idea if this works for types, but that
--  doesn\'t mean that you can\'t try it :).
--
-- read $fptools\/ghc\/compiler\/ghci\/ObjLinker.lhs for how to use this stuff
--


-- | Call the initLinker function first, before calling any of the other
-- functions in this module - otherwise you\'ll get unresolved symbols.

initLinker :: IO ()
initLinker :: IO ()
initLinker = CInt -> IO ()
initLinker_ (CInt -> IO ()) -> CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
0
-- our initLinker transparently calls the one in GHC

--
-- | Load a function from a module (which must be loaded and resolved first).
--

loadFunction :: Module          -- ^ The module the value is in
             -> String          -- ^ Symbol name of value
             -> IO (Maybe a)    -- ^ The value you want
loadFunction :: Module -> String -> IO (Maybe a)
loadFunction (Module { iface :: Module -> ModIface
iface = ModIface
i }) String
valsym
    = String -> String -> IO (Maybe a)
forall a. String -> String -> IO (Maybe a)
loadFunction_ (ModIface -> String
forall (phase :: ModIfacePhase). ModIface_ phase -> String
ifaceModuleName ModIface
i) String
valsym

loadFunction_ :: String
              -> String
              -> IO (Maybe a)
loadFunction_ :: String -> String -> IO (Maybe a)
loadFunction_ = Maybe String -> String -> String -> IO (Maybe a)
forall a. Maybe String -> String -> String -> IO (Maybe a)
loadFunction__ Maybe String
forall a. Maybe a
Nothing

loadFunction__ :: Maybe String
              -> String
              -> String
              -> IO (Maybe a)
loadFunction__ :: Maybe String -> String -> String -> IO (Maybe a)
loadFunction__ Maybe String
pkg String
m String
valsym
   = do let encode :: String -> String
encode = String -> String
zEncodeString
        String
p <- case Maybe String
pkg of
              Just String
p -> do
                Maybe String
prefix <- String -> IO (Maybe String)
pkgManglingPrefix String
p
                String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
encode (String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
p String -> String
forall a. a -> a
id Maybe String
prefix)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_"
              Maybe String
Nothing -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
        let symbol :: String
symbol = String
prefixUnderscoreString -> String -> String
forall a. [a] -> [a] -> [a]
++String
pString -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
encode String
mString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_"String -> String -> String
forall a. [a] -> [a] -> [a]
++(String -> String
encode String
valsym)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_closure"

#if DEBUG
        putStrLn $ "Looking for <<"++symbol++">>"
        initLinker
#endif
        ptr :: Ptr Any
ptr@(Ptr Addr#
addr) <- String -> (CString -> IO (Ptr Any)) -> IO (Ptr Any)
forall a. String -> (CString -> IO a) -> IO a
withCString String
symbol CString -> IO (Ptr Any)
forall a. CString -> IO (Ptr a)
c_lookupSymbol
        if (Ptr Any
ptr Ptr Any -> Ptr Any -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Any
forall a. Ptr a
nullPtr)
            then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
#if !MIN_VERSION_ghc(7,4,1)
            else case addrToHValue# addr of
#else
            else case Addr# -> (# a #)
forall a. Addr# -> (# a #)
addrToAny# Addr#
addr of
#endif
                (# a
hval #) -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return ( a -> Maybe a
forall a. a -> Maybe a
Just a
hval )


-- | Loads a function from a package module, given the package name,
--   module name and symbol name.
loadPackageFunction :: String -- ^ Package name, including version number.
                    -> String -- ^ Module name
                    -> String -- ^ Symbol to lookup in the module
                    -> IO (Maybe a)
loadPackageFunction :: String -> String -> String -> IO (Maybe a)
loadPackageFunction String
pkgName String
modName String
functionName =
    do String -> IO ()
loadPackage String
pkgName
       IO () -> IO ()
forall a. IO a -> IO ()
resolveObjs (String -> IO ()
unloadPackage String
pkgName)
       Maybe String -> String -> String -> IO (Maybe a)
forall a. Maybe String -> String -> String -> IO (Maybe a)
loadFunction__ (String -> Maybe String
forall a. a -> Maybe a
Just String
pkgName) String
modName String
functionName

--
-- | Load a GHC-compiled Haskell vanilla object file.
-- The first arg is the path to the object file
--
-- We make it idempotent to stop the nasty problem of loading the same
-- .o twice. Also the rts is a very special package that is already
-- loaded, even if we ask it to be loaded. N.B. we should insert it in
-- the list of known packages.
--
-- NB the environment stores the *full path* to an object. So if you
-- want to know if a module is already loaded, you need to supply the
-- *path* to that object, not the name.
--
-- NB -- let's try just the module name.
--
-- loadObject loads normal .o objs, and packages too. .o objs come with
-- a nice canonical Z-encoded modid. packages just have a simple name.
-- Do we want to ensure they won't clash? Probably.
--
--
--
-- the second argument to loadObject is a string to use as the unique
-- identifier for this object. For normal .o objects, it should be the
-- Z-encoded modid from the .hi file. For archives\/packages, we can
-- probably get away with the package name
--
loadObject :: FilePath -> Key -> IO Module
loadObject :: String -> Key -> IO Module
loadObject String
p ky :: Key
ky@(Object String
k)  = String -> Key -> String -> IO Module
loadObject' String
p Key
ky String
k
loadObject String
p ky :: Key
ky@(Package String
k) = String -> Key -> String -> IO Module
loadObject' String
p Key
ky String
k

loadObject' :: FilePath -> Key -> String -> IO Module
loadObject' :: String -> Key -> String -> IO Module
loadObject' String
p Key
ky String
k
    = do Bool
alreadyLoaded <- String -> IO Bool
isLoaded String
k
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
alreadyLoaded) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              let ld :: CString -> IO Bool
ld = if String
sysPkgSuffix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
p
                       then CString -> IO Bool
c_loadArchive
                       else CString -> IO Bool
c_loadObj
              Bool
r <- String -> (CString -> IO Bool) -> IO Bool
forall a. String -> (CString -> IO a) -> IO a
withCString String
p CString -> IO Bool
ld
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
r) (String -> IO ()
forall a. String -> IO a
panic (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Could not load module or package `"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
pString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'")
         let hifile :: String
hifile = String -> String -> String
replaceSuffix String
p String
hiSuf
         Bool
exists <- String -> IO Bool
doesFileExist String
hifile
         ModIface
hiface <- if Bool
exists then String -> IO ModIface
readBinIface' String
hifile else ModIface -> IO ModIface
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
forall a. HasCallStack => a
undefined
         let m :: Module
m = String -> ModIface -> Module
emptyMod String
p ModIface
hiface
         String -> Module -> IO ()
addModule String
k Module
m
         Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return Module
m

    where emptyMod :: String -> ModIface -> Module
emptyMod String
q ModIface
hiface = String -> String -> ObjType -> ModIface -> Key -> Module
Module String
q (String -> String
mkModid String
q) ObjType
Vanilla ModIface
hiface Key
ky

-- |
-- load a single object. no dependencies. You should know what you're
-- doing.
--
loadModule :: FilePath -> IO Module
loadModule :: String -> IO Module
loadModule String
obj = do
    let hifile :: String
hifile = String -> String -> String
replaceSuffix String
obj String
hiSuf
    Bool
exists <- String -> IO Bool
doesFileExist String
hifile
    if (Bool -> Bool
not Bool
exists)
        then String -> IO Module
forall a. HasCallStack => String -> a
error (String -> IO Module) -> String -> IO Module
forall a b. (a -> b) -> a -> b
$ String
"No .hi file found for "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show String
obj
        else do ModIface
hiface <- String -> IO ModIface
readBinIface' String
hifile
                String -> Key -> IO Module
loadObject String
obj (String -> Key
Object (ModIface -> String
forall (phase :: ModIfacePhase). ModIface_ phase -> String
ifaceModuleName ModIface
hiface))

--
-- | Load a generic .o file, good for loading C objects.
-- You should know what you're doing..
-- Returns a fairly meaningless iface value.
--
loadRawObject :: FilePath -> IO Module
loadRawObject :: String -> IO Module
loadRawObject String
obj = String -> Key -> IO Module
loadObject String
obj (String -> Key
Object String
k)
    where
        k :: String
k = String -> String
encode (String -> String
mkModid String
obj)  -- Z-encoded module name

--
-- | Resolve (link) the modules loaded by the 'loadObject' function.
--
resolveObjs :: IO a -> IO ()
resolveObjs :: IO a -> IO ()
resolveObjs IO a
unloadLoaded
    = do Bool
r <- IO Bool
c_resolveObjs
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
r) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO a
unloadLoaded IO a -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
forall a. String -> IO a
panic String
"resolvedObjs failed."


-- | Unload a module
unloadObj :: Module -> IO ()
unloadObj :: Module -> IO ()
unloadObj (Module { path :: Module -> String
path = String
p, kind :: Module -> ObjType
kind = ObjType
k, key :: Module -> Key
key = Key
ky }) = case ObjType
k of
        ObjType
Vanilla -> String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
p ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
c_p -> do
                Bool
removed <- String -> IO Bool
rmModule String
name
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
removed) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Bool
r <- CString -> IO Bool
c_unloadObj CString
c_p
                                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
r) (String -> IO ()
forall a. String -> IO a
panic String
"unloadObj: failed")
        ObjType
Shared  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- can't unload .so?
    where name :: String
name = case Key
ky of Object String
s -> String
s ; Package String
pk -> String
pk
--
-- | from ghci\/ObjLinker.c
--
-- Load a .so type object file.
--
loadShared :: FilePath -> IO Module
loadShared :: String -> IO Module
loadShared String
str' = do
#if DEBUG
    putStrLn $ " shared: " ++ str'
#endif
    let str :: String
str = case String
str' of
          -- TODO My GHC segfaults because libm.so is a linker script
          String
"libm.so" -> String
"/lib/x86_64-linux-gnu/libm.so.6"
          String
"libpthread.so" -> String
"/lib/x86_64-linux-gnu/libpthread.so.0"
          String
x -> String
x
    CString
maybe_errmsg <- String -> (CString -> IO CString) -> IO CString
forall a. String -> (CString -> IO a) -> IO a
withCString String
str ((CString -> IO CString) -> IO CString)
-> (CString -> IO CString) -> IO CString
forall a b. (a -> b) -> a -> b
$ \CString
dll -> CString -> IO CString
c_addDLL CString
dll
    if CString
maybe_errmsg CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
        then Module -> IO Module
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> ObjType -> ModIface -> Key -> Module
Module String
str (String -> String
mkModid String
str) ObjType
Shared ModIface
forall a. HasCallStack => a
undefined (String -> Key
Package (String -> String
mkModid String
str)))
        else do String
e <- CString -> IO String
peekCString CString
maybe_errmsg
                String -> IO Module
forall a. String -> IO a
panic (String -> IO Module) -> String -> IO Module
forall a b. (a -> b) -> a -> b
$ String
"loadShared: couldn't load `"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
strString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\' because "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
e


--
-- | Load a -package that we might need, implicitly loading the cbits too
-- The argument is the name of package (e.g.  \"concurrent\")
--
-- How to find a package is determined by the package.conf info we store
-- in the environment. It is just a matter of looking it up.
--
-- Not printing names of dependent pkgs
--
loadPackage :: String -> IO ()
loadPackage :: String -> IO ()
loadPackage String
p = do
        IO ()
initLinker
#if DEBUG
        putStr (' ':p) >> hFlush stdout
#endif
        ([String]
libs,[String]
dlls) <- String -> IO ([String], [String])
lookupPkg String
p
        (String -> IO Module) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
l -> String -> Key -> IO Module
loadObject String
l (String -> Key
Package (String -> String
mkModid String
l))) [String]
libs
#if DEBUG
        putStr (' ':show libs) >> hFlush stdout
        putStr (' ':show dlls) >> hFlush stdout
#endif
        (String -> IO Module) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO Module
loadShared [String]
dlls



--
-- | Unload a -package, that has already been loaded. Unload the cbits
-- too. The argument is the name of the package.
--
-- May need to check if it exists.
--
-- Note that we currently need to unload everything. grumble grumble.
--
-- We need to add the version number to the package name with 6.4 and
-- over. "yi-0.1" for example. This is a bug really.
--
unloadPackage :: String -> IO ()
unloadPackage :: String -> IO ()
unloadPackage String
pkg = do
    let pkg' :: String
pkg' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') String
pkg   -- in case of *-0.1
    [String]
libs <- (([String], [String]) -> [String])
-> IO ([String], [String]) -> IO [String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\([String]
a,[String]
_) -> ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSublistOf String
pkg') ) [String]
a) (String -> IO ([String], [String])
lookupPkg String
pkg)
    ((String -> IO Bool) -> [String] -> IO ())
-> [String] -> (String -> IO Bool) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> IO Bool) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [String]
libs ((String -> IO Bool) -> IO ()) -> (String -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
p -> String -> (CString -> IO Bool) -> IO Bool
forall a. String -> (CString -> IO a) -> IO a
withCString String
p ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \CString
c_p -> do
                        Bool
r <- CString -> IO Bool
c_unloadObj CString
c_p
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
r) (String -> IO ()
forall a. String -> IO a
panic String
"unloadObj: failed")
                        String -> IO Bool
rmModule (String -> String
mkModid String
p)      -- unrecord this module

--
-- | load a package using the given package.conf to help
-- TODO should report if it doesn't actually load the package, instead
-- of mapM_ doing nothing like above.
--
loadPackageWith :: String -> [PackageConf] -> IO ()
loadPackageWith :: String -> [String] -> IO ()
loadPackageWith String
p [String]
pkgconfs = do
#if DEBUG
        putStr "Loading package" >> hFlush stdout
#endif
        (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
addPkgConf [String]
pkgconfs
        String -> IO ()
loadPackage String
p
#if DEBUG
        putStrLn " done"
#endif


-- ---------------------------------------------------------------------
-- | module dependency loading
--
-- given an Foo.o vanilla object file, supposed to be a plugin compiled
-- by our library, find the associated .hi file. If this is found, load
-- the dependencies, packages first, then the modules. If it doesn't
-- exist, assume the user knows what they are doing and continue. The
-- linker will crash on them anyway. Second argument is any include
-- paths to search in
--
-- ToDo problem with absolute and relative paths, and different forms of
-- relative paths. A user may cause a dependency to be loaded, which
-- will search the incpaths, and perhaps find "./Foo.o". The user may
-- then explicitly load "Foo.o". These are the same, and the loader
-- should ignore the second load request. However, isLoaded will say
-- that "Foo.o" is not loaded, as the full string is used as a key to
-- the modenv fm. We need a canonical form for the keys -- is basename
-- good enough?
--
loadDepends :: FilePath -> [FilePath] -> IO (ModIface,[Module])
loadDepends :: String -> [String] -> IO (ModIface, [Module])
loadDepends String
obj [String]
incpaths = do
    let hifile :: String
hifile = String -> String -> String
replaceSuffix String
obj String
hiSuf
    Bool
exists <- String -> IO Bool
doesFileExist String
hifile
    if (Bool -> Bool
not Bool
exists)
        then do
#if DEBUG
                putStrLn "No .hi file found." >> hFlush stdout
#endif
                (ModIface, [Module]) -> IO (ModIface, [Module])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
forall a. HasCallStack => a
undefined,[])   -- could be considered fatal

        else do ModIface
hiface <- String -> IO ModIface
readBinIface' String
hifile
                let ds :: Dependencies
ds = ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
hiface

                -- remove ones that we've already loaded
                [String]
ds' <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
loaded ([String] -> IO [String])
-> (Dependencies -> [String]) -> Dependencies -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ModuleName, Bool) -> String) -> [(ModuleName, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> String
moduleNameString (ModuleName -> String)
-> ((ModuleName, Bool) -> ModuleName)
-> (ModuleName, Bool)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Bool) -> ModuleName
forall a b. (a, b) -> a
fst) ([(ModuleName, Bool)] -> [String])
-> (Dependencies -> [(ModuleName, Bool)])
-> Dependencies
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [(ModuleName, Bool)]
dep_mods (Dependencies -> IO [String]) -> Dependencies -> IO [String]
forall a b. (a -> b) -> a -> b
$ Dependencies
ds

                -- now, try to generate a path to the actual .o file
                -- fix up hierachical names
                let mods_ :: [(String, String)]
mods_ = (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
s -> (String
s, (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c ->
                        if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
'/' else Char
c) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
s)) [String]
ds'

                -- construct a list of possible dependent modules to load
                let mods :: [(String, String)]
mods = (String -> [(String, String)]) -> [String] -> [(String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
p ->
                            ((String, String) -> (String, String))
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
hi,String
m) -> (String
hi,String
p String -> String -> String
</> String
mString -> String -> String
forall a. [a] -> [a] -> [a]
++String
".o")) [(String, String)]
mods_) [String]
incpaths

                -- remove modules that don't exist
                [(String, String)]
mods' <- ((String, String) -> IO Bool)
-> [(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\(String
_,String
y) -> String -> IO Bool
doesFileExist String
y) ([(String, String)] -> IO [(String, String)])
-> [(String, String)] -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$
                                ((String, String) -> (String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(String, String)
v (String, String)
u -> (String, String) -> String
forall a b. (a, b) -> b
snd (String, String)
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String, String) -> String
forall a b. (a, b) -> b
snd (String, String)
u)  [(String, String)]
mods

                -- now remove duplicate valid paths to the same object
                let mods'' :: [(String, String)]
mods'' = ((String, String) -> (String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(String, String)
v (String, String)
u -> (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
u)  [(String, String)]
mods'

                -- and find some packages to load, as well.
                let ps :: [(InstalledUnitId, Bool)]
ps = Dependencies -> [(InstalledUnitId, Bool)]
dep_pkgs Dependencies
ds
#if MIN_VERSION_ghc(8,0,0)
#if MIN_VERSION_Cabal(2,0,0)
                [String]
ps' <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
loaded ([String] -> IO [String])
-> ([InstalledUnitId] -> [String])
-> [InstalledUnitId]
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledUnitId -> String) -> [InstalledUnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map InstalledUnitId -> String
installedUnitIdString ([InstalledUnitId] -> [String])
-> ([InstalledUnitId] -> [InstalledUnitId])
-> [InstalledUnitId]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledUnitId] -> [InstalledUnitId]
forall a. Eq a => [a] -> [a]
nub ([InstalledUnitId] -> IO [String])
-> [InstalledUnitId] -> IO [String]
forall a b. (a -> b) -> a -> b
$ ((InstalledUnitId, Bool) -> InstalledUnitId)
-> [(InstalledUnitId, Bool)] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId, Bool) -> InstalledUnitId
forall a b. (a, b) -> a
fst [(InstalledUnitId, Bool)]
ps
#else
                ps' <- filterM loaded . map unitIdString . nub $ map fst ps
#endif
#elif MIN_VERSION_ghc(7,10,0)
                ps' <- filterM loaded . map packageKeyString . nub $ map fst ps
#elif MIN_VERSION_ghc(7,2,0)
                ps' <- filterM loaded . map packageIdString . nub $ map fst ps
#else
                ps' <- filterM loaded . map packageIdString . nub $ ps
#endif

#if DEBUG
                when (not (null ps')) $
                        putStr "Loading package" >> hFlush stdout
#endif
                (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
loadPackage [String]
ps'
#if DEBUG
                when (not (null ps')) $
                        putStr " ... linking ... " >> hFlush stdout
#endif
                IO () -> IO ()
forall a. IO a -> IO ()
resolveObjs ((String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
unloadPackage [String]
ps')
#if DEBUG
                when (not (null ps')) $ putStrLn "done"
                putStr "Loading object"
                mapM_ (\(m,_) -> putStr (" "++ m) >> hFlush stdout) mods''
#endif
                [Module]
moduleDeps <- ((String, String) -> IO Module)
-> [(String, String)] -> IO [Module]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(String
hi,String
m) -> String -> Key -> IO Module
loadObject String
m (String -> Key
Object String
hi)) [(String, String)]
mods''
                (ModIface, [Module]) -> IO (ModIface, [Module])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
hiface,[Module]
moduleDeps)

-- ---------------------------------------------------------------------
-- | Nice interface to .hi parser
--
getImports :: String -> IO [String]
getImports :: String -> IO [String]
getImports String
m = do
        ModIface
hi <- String -> IO ModIface
readBinIface' (String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hiSuf)
        [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String])
-> (ModIface -> [String]) -> ModIface -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ModuleName, Bool) -> String) -> [(ModuleName, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> String
moduleNameString (ModuleName -> String)
-> ((ModuleName, Bool) -> ModuleName)
-> (ModuleName, Bool)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Bool) -> ModuleName
forall a b. (a, b) -> a
fst) ([(ModuleName, Bool)] -> [String])
-> (ModIface -> [(ModuleName, Bool)]) -> ModIface -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [(ModuleName, Bool)]
dep_mods (Dependencies -> [(ModuleName, Bool)])
-> (ModIface -> Dependencies) -> ModIface -> [(ModuleName, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps (ModIface -> IO [String]) -> ModIface -> IO [String]
forall a b. (a -> b) -> a -> b
$ ModIface
hi

-- ---------------------------------------------------------------------
-- C interface
--
foreign import ccall safe "lookupSymbol"
   c_lookupSymbol :: CString -> IO (Ptr a)

foreign import ccall unsafe "loadObj"
   c_loadObj :: CString -> IO Bool

foreign import ccall unsafe "unloadObj"
   c_unloadObj :: CString -> IO Bool

foreign import ccall unsafe "loadArchive"
   c_loadArchive :: CString -> IO Bool

foreign import ccall unsafe "resolveObjs"
   c_resolveObjs :: IO Bool

foreign import ccall unsafe "addDLL"
   c_addDLL :: CString -> IO CString

foreign import ccall unsafe "initLinker_"
   initLinker_ :: CInt -> IO ()