module GHC.Linker.MacOS
( runInjectRPaths
, getUnitFrameworks
, getUnitFrameworkOpts
, getUnitFrameworkPath
, getFrameworkOpts
, loadFramework
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Unit.Types
import GHC.Unit.State
import GHC.Unit.Home
import GHC.SysTools.Tasks
import GHC.Runtime.Interpreter (loadDLL)
import GHC.Utils.Outputable
import GHC.Utils.Exception
import GHC.Utils.Misc (ordNub )
import qualified GHC.Data.ShortText as ST
import Data.List
import Control.Monad (join, forM, filterM)
import System.Directory (doesFileExist, getHomeDirectory)
import System.FilePath ((</>), (<.>))
runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()
runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()
runInjectRPaths DynFlags
dflags [FilePath]
lib_paths FilePath
dylib = do
[FilePath]
info <- FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> Maybe FilePath -> [Option] -> IO FilePath
askOtool DynFlags
dflags Maybe FilePath
forall a. Maybe a
Nothing [FilePath -> Option
Option FilePath
"-L", FilePath -> Option
Option FilePath
dylib]
let libs :: [FilePath]
libs = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([FilePath] -> FilePath
forall a. [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
[[FilePath]]
info <- (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> [FilePath]
words([FilePath] -> [[FilePath]])
-> (FilePath -> [FilePath]) -> FilePath -> [[FilePath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.FilePath -> [FilePath]
lines (FilePath -> [[FilePath]]) -> IO FilePath -> IO [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> Maybe FilePath -> [Option] -> IO FilePath
askOtool DynFlags
dflags Maybe FilePath
forall a. Maybe a
Nothing [FilePath -> Option
Option FilePath
"-l", FilePath -> Option
Option FilePath
dylib]
let paths :: [FilePath]
paths = ([FilePath] -> [FilePath]) -> [[FilePath]] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [FilePath] -> [FilePath]
f [[FilePath]]
info
where f :: [FilePath] -> [FilePath]
f (FilePath
"path":FilePath
p:[FilePath]
_) = [FilePath
p]
f [FilePath]
_ = []
lib_paths' :: [FilePath]
lib_paths' = [ FilePath
p | FilePath
p <- [FilePath]
lib_paths, Bool -> Bool
not (FilePath
p FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
paths) ]
[FilePath]
rpaths <- [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath])
-> ([[FilePath]] -> [FilePath]) -> [[FilePath]] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath])
-> ([[FilePath]] -> [FilePath]) -> [[FilePath]] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[FilePath]] -> [FilePath]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath] -> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
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 [FilePath]
rpaths of
[] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[FilePath]
_ -> DynFlags -> [Option] -> IO ()
runInstallNameTool DynFlags
dflags ([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]
getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]
getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [FilePath]
getUnitFrameworkOpts DynFlags
dflags Platform
platform [UnitId]
dep_packages
| Platform -> Bool
platformUsesFrameworks Platform
platform = do
[FilePath]
pkg_framework_path_opts <- do
[FilePath]
pkg_framework_paths <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitFrameworkPath
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
(DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags)
[UnitId]
dep_packages
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-F" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) [FilePath]
pkg_framework_paths
[FilePath]
pkg_framework_opts <- do
[FilePath]
pkg_frameworks <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitFrameworks
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
(DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags)
[UnitId]
dep_packages
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [FilePath
"-framework", FilePath
fw] | FilePath
fw <- [FilePath]
pkg_frameworks ]
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
pkg_framework_path_opts [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_framework_opts)
| Bool
otherwise = [FilePath] -> IO [FilePath]
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 [FilePath] -> [FilePath] -> [FilePath]
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 = (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 = DynFlags -> [FilePath]
cmdlineFrameworks DynFlags
dflags
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 ]
getUnitFrameworkPath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
getUnitFrameworkPath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitFrameworkPath SDocContext
ctx UnitState
unit_state HomeUnit
home_unit [UnitId]
pkgs = do
[UnitInfo]
ps <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd SDocContext
ctx UnitState
unit_state HomeUnit
home_unit [UnitId]
pkgs
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (ShortText -> FilePath) -> [ShortText] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> FilePath
ST.unpack ([ShortText] -> [ShortText]
forall a. Ord a => [a] -> [a]
ordNub ((ShortText -> Bool) -> [ShortText] -> [ShortText]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ShortText -> Bool) -> ShortText -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> Bool
ST.null) ((UnitInfo -> [ShortText]) -> [UnitInfo] -> [ShortText]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepFrameworkDirs [UnitInfo]
ps)))
getUnitFrameworks :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
getUnitFrameworks :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitFrameworks SDocContext
ctx UnitState
unit_state HomeUnit
home_unit [UnitId]
pkgs = do
[UnitInfo]
ps <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd SDocContext
ctx UnitState
unit_state HomeUnit
home_unit [UnitId]
pkgs
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (ShortText -> FilePath) -> [ShortText] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> FilePath
ST.unpack ((UnitInfo -> [ShortText]) -> [UnitInfo] -> [ShortText]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepFrameworks [UnitInfo]
ps)
loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)
loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe FilePath)
loadFramework HscEnv
hsc_env [FilePath]
extraPaths FilePath
rootname
= do { Either IOException FilePath
either_dir <- IO FilePath -> IO (Either IOException FilePath)
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 [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
homeFrameworkPath [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
defaultFrameworkPaths
; Maybe [FilePath]
errs <- [FilePath] -> [FilePath] -> IO (Maybe [FilePath])
findLoadDLL [FilePath]
ps []
; Maybe FilePath -> IO (Maybe FilePath)
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] -> FilePath) -> Maybe [FilePath] -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> [FilePath] -> FilePath
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 =
Maybe [FilePath] -> IO (Maybe [FilePath])
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 { Maybe FilePath
dll <- HscEnv -> FilePath -> IO (Maybe FilePath)
loadDLL HscEnv
hsc_env (FilePath
p FilePath -> FilePath -> FilePath
</> FilePath
fwk_file)
; case Maybe FilePath
dll of
Maybe FilePath
Nothing -> Maybe [FilePath] -> IO (Maybe [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [FilePath]
forall a. Maybe a
Nothing
Just 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)
}