module GHC.Linker.Unit
( collectLinkOpts
, collectArchives
, collectLibraryPaths
, getUnitLinkOpts
, getUnitLibraryPath
, getLibs
, packageHsLibs
)
where
import GHC.Prelude
import GHC.Platform.Ways
import GHC.Unit.Types
import GHC.Unit.Info
import GHC.Unit.State
import GHC.Unit.Home
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import qualified GHC.Data.ShortText as ST
import GHC.Driver.Session
import qualified Data.Set as Set
import Data.List (isPrefixOf, stripPrefix)
import Control.Monad
import System.Directory
import System.FilePath
getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
getUnitLinkOpts DynFlags
dflags [UnitId]
pkgs =
DynFlags -> [UnitInfo] -> ([String], [String], [String])
collectLinkOpts DynFlags
dflags ([UnitInfo] -> ([String], [String], [String]))
-> IO [UnitInfo] -> IO ([String], [String], [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
(DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags)
[UnitId]
pkgs
collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])
collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])
collectLinkOpts DynFlags
dflags [UnitInfo]
ps =
(
(UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-l" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (UnitInfo -> [String]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> UnitInfo -> [String]
packageHsLibs DynFlags
dflags) [UnitInfo]
ps,
(UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-l" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (UnitInfo -> [String]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShortText -> String) -> [ShortText] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> String
ST.unpack ([ShortText] -> [String])
-> (UnitInfo -> [ShortText]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepLibsSys) [UnitInfo]
ps,
(UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((ShortText -> String) -> [ShortText] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> String
ST.unpack ([ShortText] -> [String])
-> (UnitInfo -> [ShortText]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLinkerOptions) [UnitInfo]
ps
)
collectArchives :: DynFlags -> UnitInfo -> IO [FilePath]
collectArchives :: DynFlags -> UnitInfo -> IO [String]
collectArchives DynFlags
dflags UnitInfo
pc =
(String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [ String
searchPath String -> String -> String
</> (String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".a")
| String
searchPath <- [String]
searchPaths
, String
lib <- [String]
libs ]
where searchPaths :: [String]
searchPaths = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ([String] -> [String])
-> (UnitInfo -> [String]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull ([String] -> [String])
-> (UnitInfo -> [String]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ways -> UnitInfo -> [String]
libraryDirsForWay (DynFlags -> Ways
ways DynFlags
dflags) (UnitInfo -> [String]) -> UnitInfo -> [String]
forall a b. (a -> b) -> a -> b
$ UnitInfo
pc
libs :: [String]
libs = DynFlags -> UnitInfo -> [String]
packageHsLibs DynFlags
dflags UnitInfo
pc [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (ShortText -> String) -> [ShortText] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> String
ST.unpack (UnitInfo -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepLibsSys UnitInfo
pc)
collectLibraryPaths :: Ways -> [UnitInfo] -> [FilePath]
collectLibraryPaths :: Ways -> [UnitInfo] -> [String]
collectLibraryPaths Ways
ws = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ([String] -> [String])
-> ([UnitInfo] -> [String]) -> [UnitInfo] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull
([String] -> [String])
-> ([UnitInfo] -> [String]) -> [UnitInfo] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Ways -> UnitInfo -> [String]
libraryDirsForWay Ways
ws)
libraryDirsForWay :: Ways -> UnitInfo -> [String]
libraryDirsForWay :: Ways -> UnitInfo -> [String]
libraryDirsForWay Ways
ws
| Way
WayDyn Way -> Ways -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Ways
ws = (ShortText -> String) -> [ShortText] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> String
ST.unpack ([ShortText] -> [String])
-> (UnitInfo -> [ShortText]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraryDynDirs
| Bool
otherwise = (ShortText -> String) -> [ShortText] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> String
ST.unpack ([ShortText] -> [String])
-> (UnitInfo -> [ShortText]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraryDirs
getLibs :: DynFlags -> [UnitId] -> IO [(String,String)]
getLibs :: DynFlags -> [UnitId] -> IO [(String, String)]
getLibs DynFlags
dflags [UnitId]
pkgs = do
[UnitInfo]
ps <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
(DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags)
[UnitId]
pkgs
([[(String, String)]] -> [(String, String)])
-> IO [[(String, String)]] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[(String, String)]] -> IO [(String, String)])
-> ((UnitInfo -> IO [(String, String)]) -> IO [[(String, String)]])
-> (UnitInfo -> IO [(String, String)])
-> IO [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitInfo]
-> (UnitInfo -> IO [(String, String)]) -> IO [[(String, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnitInfo]
ps ((UnitInfo -> IO [(String, String)]) -> IO [(String, String)])
-> (UnitInfo -> IO [(String, String)]) -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ \UnitInfo
p -> do
let candidates :: [(String, String)]
candidates = [ (String
l String -> String -> String
</> String
f, String
f) | String
l <- Ways -> [UnitInfo] -> [String]
collectLibraryPaths (DynFlags -> Ways
ways DynFlags
dflags) [UnitInfo
p]
, String
f <- (\String
n -> String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".a") (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> UnitInfo -> [String]
packageHsLibs DynFlags
dflags UnitInfo
p ]
((String, String) -> IO Bool)
-> [(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist (String -> IO Bool)
-> ((String, String) -> String) -> (String, String) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
candidates
getUnitLibraryPath :: SDocContext -> UnitState -> HomeUnit -> Ways -> [UnitId] -> IO [String]
getUnitLibraryPath :: SDocContext
-> UnitState -> HomeUnit -> Ways -> [UnitId] -> IO [String]
getUnitLibraryPath SDocContext
ctx UnitState
unit_state HomeUnit
home_unit Ways
ws [UnitId]
pkgs =
Ways -> [UnitInfo] -> [String]
collectLibraryPaths Ways
ws ([UnitInfo] -> [String]) -> IO [UnitInfo] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd SDocContext
ctx UnitState
unit_state HomeUnit
home_unit [UnitId]
pkgs
packageHsLibs :: DynFlags -> UnitInfo -> [String]
packageHsLibs :: DynFlags -> UnitInfo -> [String]
packageHsLibs DynFlags
dflags UnitInfo
p = (ShortText -> String) -> [ShortText] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
mkDynName (String -> String) -> (ShortText -> String) -> ShortText -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
addSuffix (String -> String) -> (ShortText -> String) -> ShortText -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> String
ST.unpack) (UnitInfo -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraries UnitInfo
p)
where
ways0 :: Ways
ways0 = DynFlags -> Ways
ways DynFlags
dflags
ways1 :: Ways
ways1 = (Way -> Bool) -> Ways -> Ways
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
/= Way
WayDyn) Ways
ways0
ways2 :: Ways
ways2 | Way
WayDebug Way -> Ways -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Ways
ways1 Bool -> Bool -> Bool
|| Way
WayProf Way -> Ways -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Ways
ways1
= (Way -> Bool) -> Ways -> Ways
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
/= Way
WayTracing) Ways
ways1
| Bool
otherwise
= Ways
ways1
tag :: String
tag = Ways -> String
waysTag (Ways -> Ways
fullWays Ways
ways2)
rts_tag :: String
rts_tag = Ways -> String
waysTag Ways
ways2
mkDynName :: String -> String
mkDynName String
x
| Bool -> Bool
not (DynFlags -> Ways
ways DynFlags
dflags Ways -> Way -> Bool
`hasWay` Way
WayDyn) = String
x
| String
"HS" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x =
String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:DynFlags -> String
programName DynFlags
dflags String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> String
projectVersion DynFlags
dflags
| Just String
x' <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"C" String
x = String
x'
| Bool
otherwise
= String -> String
forall a. String -> a
panic (String
"Don't understand library name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)
addSuffix :: String -> String
addSuffix rts :: String
rts@String
"HSrts" = String
rts String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
expandTag String
rts_tag)
addSuffix rts :: String
rts@String
"HSrts-1.0"= String
rts String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
expandTag String
rts_tag)
addSuffix String
other_lib = String
other_lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
expandTag String
tag)
expandTag :: String -> String
expandTag String
t | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t = String
""
| Bool
otherwise = Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
t