-- | Linking Haskell units
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

-- | Find all the link options in these and the preload packages,
-- returning (package hs lib options, extra library options, other flags)
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)

-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.
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

-- | Find all the library paths in these and the preload packages
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
        -- the name of a shared library is libHSfoo-ghc<version>.so
        -- we leave out the _dyn, because it is superfluous

        -- debug and profiled RTSs include support for -eventlog
        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
           -- For non-Haskell libraries, we use the name "Cfoo". The .a
           -- file is libCfoo.a, and the .so is libfoo.so. That way the
           -- linker knows what we mean for the vanilla (-lCfoo) and dyn
           -- (-lfoo) ways. We therefore need to strip the 'C' off here.
         | 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)

        -- Add _thr and other rts suffixes to packages named
        -- `rts` or `rts-1.0`. Why both?  Traditionally the rts
        -- package is called `rts` only.  However the tooling
        -- usually expects a package name to have a version.
        -- As such we will gradually move towards the `rts-1.0`
        -- package name, at which point the `rts` package name
        -- will eventually be unused.
        --
        -- This change elevates the need to add custom hooks
        -- and handling specifically for the `rts` package for
        -- example in ghc-cabal.
        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