module GHC.Linker.MacOS
( runInjectRPaths
, getUnitFrameworkOpts
, getFrameworkOpts
, loadFramework
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Driver.Session
import GHC.Unit.Types
import GHC.Unit.State
import GHC.Unit.Env
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 -> DynFlags -> [FilePath] -> FilePath -> IO ()
runInjectRPaths :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO ()
runInjectRPaths Logger
_ DynFlags
dflags [FilePath]
_ FilePath
_ | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RPath DynFlags
dflags) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
runInjectRPaths Logger
logger DynFlags
dflags [FilePath]
lib_paths FilePath
dylib = do
[FilePath]
info <- FilePath -> [FilePath]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO FilePath
askOtool Logger
logger DynFlags
dflags forall a. Maybe a
Nothing [FilePath -> Option
Option FilePath
"-L", FilePath -> Option
Option FilePath
dylib]
let libs :: [FilePath]
libs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Int -> [a] -> [a]
drop Int
7) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"@rpath") forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> a
headforall b c a. (b -> c) -> (a -> b) -> a -> c
.FilePath -> [FilePath]
words) forall a b. (a -> b) -> a -> b
$ [FilePath]
info
[FilePath]
info <- FilePath -> [FilePath]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO FilePath
askOtool Logger
logger DynFlags
dflags forall a. Maybe a
Nothing [FilePath -> Option
Option FilePath
"-l", FilePath -> Option
Option FilePath
dylib]
let paths :: [FilePath]
paths = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe FilePath
get_rpath [FilePath]
info
lib_paths' :: [FilePath]
lib_paths' = [ FilePath
p | FilePath
p <- [FilePath]
lib_paths, Bool -> Bool
not (FilePath
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
paths) ]
[FilePath]
rpaths <- forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
libs (\FilePath
f -> 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 [FilePath]
rpaths of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[FilePath]
_ -> Logger -> DynFlags -> [Option] -> IO ()
runInstallNameTool Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
Option forall a b. (a -> b) -> a -> b
$ FilePath
"-add_rpath"forall a. a -> [a] -> [a]
:(forall a. a -> [a] -> [a]
intersperse FilePath
"-add_rpath" [FilePath]
rpaths) forall a. [a] -> [a] -> [a]
++ [FilePath
dylib]
get_rpath :: String -> Maybe FilePath
get_rpath :: FilePath -> Maybe FilePath
get_rpath FilePath
l = case forall a. ReadP a -> ReadS a
readP_to_S ReadP FilePath
rpath_parser FilePath
l of
[(FilePath
rpath, FilePath
"")] -> forall a. a -> Maybe a
Just FilePath
rpath
[(FilePath, FilePath)]
_ -> forall a. Maybe a
Nothing
rpath_parser :: ReadP FilePath
rpath_parser :: ReadP FilePath
rpath_parser = do
ReadP ()
skipSpaces
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ FilePath -> ReadP FilePath
string FilePath
"path"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isSpace)
FilePath
rpath <- forall a. ReadP a -> ReadP [a]
many ReadP Char
get
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isSpace)
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ FilePath -> ReadP FilePath
string FilePath
"(offset "
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ReadP FilePath
munch1 Char -> Bool
isDigit
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
Parser.char Char
')'
ReadP ()
skipSpaces
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
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
[UnitInfo]
ps <- 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]
pkg_framework_path_opts = forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-F" forall a. [a] -> [a] -> [a]
++) ([UnitInfo] -> [FilePath]
collectFrameworksDirs [UnitInfo]
ps)
pkg_framework_opts :: [FilePath]
pkg_framework_opts = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [FilePath
"-framework", FilePath
fw]
| FilePath
fw <- [UnitInfo] -> [FilePath]
collectFrameworks [UnitInfo]
ps
]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
pkg_framework_path_opts forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_framework_opts)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return []
getFrameworkOpts :: DynFlags -> Platform -> [String]
getFrameworkOpts :: DynFlags -> Platform -> [FilePath]
getFrameworkOpts DynFlags
dflags Platform
platform
| Platform -> Bool
platformUsesFrameworks Platform
platform = [FilePath]
framework_path_opts forall a. [a] -> [a] -> [a]
++ [FilePath]
framework_opts
| Bool
otherwise = []
where
framework_paths :: [FilePath]
framework_paths = DynFlags -> [FilePath]
frameworkPaths DynFlags
dflags
framework_path_opts :: [FilePath]
framework_path_opts = forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-F" forall a. [a] -> [a] -> [a]
++) [FilePath]
framework_paths
frameworks :: [FilePath]
frameworks = DynFlags -> [FilePath]
cmdlineFrameworks DynFlags
dflags
framework_opts :: [FilePath]
framework_opts = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [FilePath
"-framework", FilePath
fw]
| FilePath
fw <- 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 IOException FilePath
either_dir <- forall a. IO a -> IO (Either IOException a)
tryIO IO FilePath
getHomeDirectory
; let homeFrameworkPath :: [FilePath]
homeFrameworkPath = case Either IOException FilePath
either_dir of
Left IOException
_ -> []
Right FilePath
dir -> [FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"Library/Frameworks"]
ps :: [FilePath]
ps = [FilePath]
extraPaths forall a. [a] -> [a] -> [a]
++ [FilePath]
homeFrameworkPath forall a. [a] -> [a] -> [a]
++ [FilePath]
defaultFrameworkPaths
; Maybe [FilePath]
errs <- [FilePath] -> [FilePath] -> IO (Maybe [FilePath])
findLoadDLL [FilePath]
ps []
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", ") Maybe [FilePath]
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 =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [FilePath]
errs
findLoadDLL (FilePath
p:[FilePath]
ps) [FilePath]
errs =
do { Maybe FilePath
dll <- Interp -> FilePath -> IO (Maybe FilePath)
loadDLL Interp
interp (FilePath
p FilePath -> FilePath -> FilePath
</> FilePath
fwk_file)
; case Maybe FilePath
dll of
Maybe FilePath
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just FilePath
err -> [FilePath] -> [FilePath] -> IO (Maybe [FilePath])
findLoadDLL [FilePath]
ps ((FilePath
p forall a. [a] -> [a] -> [a]
++ FilePath
": " forall a. [a] -> [a] -> [a]
++ FilePath
err)forall a. a -> [a] -> [a]
:[FilePath]
errs)
}