module GHC.Linker.MacOS
( runInjectRPaths
, getUnitFrameworkOpts
, getFrameworkOpts
, loadFramework
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Linker.Config
import GHC.Driver.DynFlags
import GHC.Unit.Types
import GHC.Unit.State
import GHC.Unit.Env
import GHC.Settings
import GHC.SysTools.Tasks
import GHC.Runtime.Interpreter
import GHC.Utils.Exception
import GHC.Utils.Logger
import Data.List (isPrefixOf, nub, sort, intersperse, intercalate)
import Data.Char
import Data.Maybe
import Control.Monad (join, forM, filterM, void)
import System.Directory (doesFileExist, getHomeDirectory)
import System.FilePath ((</>), (<.>))
import Text.ParserCombinators.ReadP as Parser
runInjectRPaths :: Logger -> ToolSettings -> [FilePath] -> FilePath -> IO ()
runInjectRPaths :: Logger -> ToolSettings -> [FilePath] -> FilePath -> IO ()
runInjectRPaths Logger
logger ToolSettings
toolSettings [FilePath]
lib_paths FilePath
dylib = do
info <- FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Logger -> ToolSettings -> Maybe FilePath -> [Option] -> IO FilePath
askOtool Logger
logger ToolSettings
toolSettings Maybe FilePath
forall a. Maybe a
Nothing [FilePath -> Option
Option FilePath
"-L", FilePath -> Option
Option FilePath
dylib]
let libs = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
7) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"@rpath") ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([FilePath] -> FilePath
forall a. HasCallStack => [a] -> a
head([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.FilePath -> [FilePath]
words) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath]
info
info <- lines <$> askOtool logger toolSettings Nothing [Option "-l", Option dylib]
let paths = (FilePath -> Maybe FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe FilePath
get_rpath [FilePath]
info
lib_paths' = [ FilePath
p | FilePath
p <- [FilePath]
lib_paths, Bool -> Bool
not (FilePath
p FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
paths) ]
rpaths <- nub . sort . join <$> forM libs (\FilePath
f -> (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\FilePath
l -> FilePath -> IO Bool
doesFileExist (FilePath
l FilePath -> FilePath -> FilePath
</> FilePath
f)) [FilePath]
lib_paths')
case rpaths of
[] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[FilePath]
_ -> Logger -> ToolSettings -> [Option] -> IO ()
runInstallNameTool Logger
logger ToolSettings
toolSettings ([Option] -> IO ()) -> [Option] -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
Option ([FilePath] -> [Option]) -> [FilePath] -> [Option]
forall a b. (a -> b) -> a -> b
$ FilePath
"-add_rpath"FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:(FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
intersperse FilePath
"-add_rpath" [FilePath]
rpaths) [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
dylib]
get_rpath :: String -> Maybe FilePath
get_rpath :: FilePath -> Maybe FilePath
get_rpath FilePath
l = case ReadP FilePath -> ReadS FilePath
forall a. ReadP a -> ReadS a
readP_to_S ReadP FilePath
rpath_parser FilePath
l of
[(FilePath
rpath, FilePath
"")] -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
rpath
[(FilePath, FilePath)]
_ -> Maybe FilePath
forall a. Maybe a
Nothing
rpath_parser :: ReadP FilePath
rpath_parser :: ReadP FilePath
rpath_parser = do
ReadP ()
skipSpaces
ReadP FilePath -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP FilePath -> ReadP ()) -> ReadP FilePath -> ReadP ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ReadP FilePath
string FilePath
"path"
ReadP FilePath -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP FilePath -> ReadP ()) -> ReadP FilePath -> ReadP ()
forall a b. (a -> b) -> a -> b
$ ReadP Char -> ReadP FilePath
forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isSpace)
rpath <- ReadP Char -> ReadP FilePath
forall a. ReadP a -> ReadP [a]
many ReadP Char
get
void $ many1 (satisfy isSpace)
void $ string "(offset "
void $ munch1 isDigit
void $ Parser.char ')'
skipSpaces
return rpath
getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String]
getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [FilePath]
getUnitFrameworkOpts UnitEnv
unit_env [UnitId]
dep_packages
| Platform -> Bool
platformUsesFrameworks (UnitEnv -> Platform
ue_platform UnitEnv
unit_env) = do
ps <- MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo]
forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo' UnitEnv
unit_env [UnitId]
dep_packages)
let pkg_framework_path_opts = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-F" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) ([UnitInfo] -> [FilePath]
collectFrameworksDirs [UnitInfo]
ps)
pkg_framework_opts = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [FilePath
"-framework", FilePath
fw]
| FilePath
fw <- [UnitInfo] -> [FilePath]
collectFrameworks [UnitInfo]
ps
]
return (pkg_framework_path_opts ++ pkg_framework_opts)
| Bool
otherwise = [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
getFrameworkOpts :: FrameworkOpts -> Platform -> [String]
getFrameworkOpts :: FrameworkOpts -> Platform -> [FilePath]
getFrameworkOpts FrameworkOpts
fwOpts Platform
platform
| Platform -> Bool
platformUsesFrameworks Platform
platform = [FilePath]
framework_path_opts [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
framework_opts
| Bool
otherwise = []
where
framework_paths :: [FilePath]
framework_paths = FrameworkOpts -> [FilePath]
foFrameworkPaths FrameworkOpts
fwOpts
framework_path_opts :: [FilePath]
framework_path_opts = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-F" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) [FilePath]
framework_paths
frameworks :: [FilePath]
frameworks = FrameworkOpts -> [FilePath]
foCmdlineFrameworks FrameworkOpts
fwOpts
framework_opts :: [FilePath]
framework_opts = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [FilePath
"-framework", FilePath
fw]
| FilePath
fw <- [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
frameworks ]
loadFramework :: Interp -> [FilePath] -> FilePath -> IO (Maybe String)
loadFramework :: Interp -> [FilePath] -> FilePath -> IO (Maybe FilePath)
loadFramework Interp
interp [FilePath]
extraPaths FilePath
rootname
= do { either_dir <- IO FilePath -> IO (Either IOException FilePath)
forall a. IO a -> IO (Either IOException a)
tryIO IO FilePath
getHomeDirectory
; let homeFrameworkPath = case Either IOException FilePath
either_dir of
Left IOException
_ -> []
Right FilePath
dir -> [FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"Library/Frameworks"]
ps = [FilePath]
extraPaths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
homeFrameworkPath [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
defaultFrameworkPaths
; errs <- findLoadDLL ps []
; return $ fmap (intercalate ", ") errs
}
where
fwk_file :: FilePath
fwk_file = FilePath
rootname FilePath -> FilePath -> FilePath
<.> FilePath
"framework" FilePath -> FilePath -> FilePath
</> FilePath
rootname
defaultFrameworkPaths :: [FilePath]
defaultFrameworkPaths = [FilePath
"/Library/Frameworks", FilePath
"/System/Library/Frameworks"]
findLoadDLL :: [FilePath] -> [FilePath] -> IO (Maybe [FilePath])
findLoadDLL [] [FilePath]
errs =
Maybe [FilePath] -> IO (Maybe [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [FilePath] -> IO (Maybe [FilePath]))
-> Maybe [FilePath] -> IO (Maybe [FilePath])
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Maybe [FilePath]
forall a. a -> Maybe a
Just [FilePath]
errs
findLoadDLL (FilePath
p:[FilePath]
ps) [FilePath]
errs =
do { dll <- Interp -> FilePath -> IO (Either FilePath (RemotePtr LoadedDLL))
loadDLL Interp
interp (FilePath
p FilePath -> FilePath -> FilePath
</> FilePath
fwk_file)
; case dll of
Right RemotePtr LoadedDLL
_ -> Maybe [FilePath] -> IO (Maybe [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [FilePath]
forall a. Maybe a
Nothing
Left FilePath
err -> [FilePath] -> [FilePath] -> IO (Maybe [FilePath])
findLoadDLL [FilePath]
ps ((FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err)FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
errs)
}