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 _ dflags _ _ | not (gopt Opt_RPath dflags) = return ()
runInjectRPaths logger dflags lib_paths dylib = do
info <- lines <$> askOtool logger dflags Nothing [Option "-L", Option dylib]
let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info
info <- lines <$> askOtool logger dflags Nothing [Option "-l", Option dylib]
let paths = mapMaybe get_rpath info
lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]
rpaths <- nub . sort . join <$> forM libs (\f -> filterM (\l -> doesFileExist (l </> f)) lib_paths')
case rpaths of
[] -> return ()
_ -> runInstallNameTool logger dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
get_rpath :: String -> Maybe FilePath
get_rpath l = case readP_to_S rpath_parser l of
[(rpath, "")] -> Just rpath
_ -> Nothing
rpath_parser :: ReadP FilePath
rpath_parser = do
skipSpaces
void $ string "path"
void $ many1 (satisfy isSpace)
rpath <- many get
void $ many1 (satisfy isSpace)
void $ string "(offset "
void $ munch1 isDigit
void $ Parser.char ')'
skipSpaces
return rpath
getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String]
getUnitFrameworkOpts unit_env dep_packages
| platformUsesFrameworks (ue_platform unit_env) = do
ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)
let pkg_framework_path_opts = map ("-F" ++) (collectFrameworksDirs ps)
pkg_framework_opts = concat [ ["-framework", fw]
| fw <- collectFrameworks ps
]
return (pkg_framework_path_opts ++ pkg_framework_opts)
| otherwise = return []
getFrameworkOpts :: DynFlags -> Platform -> [String]
getFrameworkOpts dflags platform
| platformUsesFrameworks platform = framework_path_opts ++ framework_opts
| otherwise = []
where
framework_paths = frameworkPaths dflags
framework_path_opts = map ("-F" ++) framework_paths
frameworks = cmdlineFrameworks dflags
framework_opts = concat [ ["-framework", fw]
| fw <- reverse frameworks ]
loadFramework :: Interp -> [FilePath] -> FilePath -> IO (Maybe String)
loadFramework interp extraPaths rootname
= do { either_dir <- tryIO getHomeDirectory
; let homeFrameworkPath = case either_dir of
Left _ -> []
Right dir -> [dir </> "Library/Frameworks"]
ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
; errs <- findLoadDLL ps []
; return $ fmap (intercalate ", ") errs
}
where
fwk_file = rootname <.> "framework" </> rootname
defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
findLoadDLL [] errs =
return $ Just errs
findLoadDLL (p:ps) errs =
do { dll <- loadDLL interp (p </> fwk_file)
; case dll of
Nothing -> return Nothing
Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)
}