-- | Linking Haskell units
module GHC.Linker.Unit
   ( UnitLinkOpts (..)
   , collectLinkOpts
   , collectArchives
   , getUnitLinkOpts
   , getLibs
   , getUnitDepends
   )
where

import GHC.Driver.DynFlags
import GHC.Prelude
import GHC.Platform.Ways
import GHC.Unit.Types
import GHC.Unit.Info
import GHC.Unit.State
import GHC.Unit.Env
import GHC.Utils.Misc
import GHC.Utils.Panic

import qualified GHC.Data.ShortText as ST

import GHC.Settings

import Control.Monad
import Data.List (nub)
import Data.Semigroup ( Semigroup(..) )
import System.Directory
import System.FilePath

-- | Linker flags collected from units
data UnitLinkOpts = UnitLinkOpts
  { UnitLinkOpts -> [[Char]]
hsLibs     :: [String] -- ^ Haskell libraries (as a list of "-lHSfoo...")
  , UnitLinkOpts -> [[Char]]
extraLibs  :: [String] -- ^ External libraries (as a list of "-lfoo...")
  , UnitLinkOpts -> [[Char]]
otherFlags :: [String] -- ^ Extra linker options
  }
  deriving (Int -> UnitLinkOpts -> ShowS
[UnitLinkOpts] -> ShowS
UnitLinkOpts -> [Char]
(Int -> UnitLinkOpts -> ShowS)
-> (UnitLinkOpts -> [Char])
-> ([UnitLinkOpts] -> ShowS)
-> Show UnitLinkOpts
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnitLinkOpts -> ShowS
showsPrec :: Int -> UnitLinkOpts -> ShowS
$cshow :: UnitLinkOpts -> [Char]
show :: UnitLinkOpts -> [Char]
$cshowList :: [UnitLinkOpts] -> ShowS
showList :: [UnitLinkOpts] -> ShowS
Show)

instance Semigroup UnitLinkOpts where
  (UnitLinkOpts [[Char]]
l1 [[Char]]
el1 [[Char]]
of1) <> :: UnitLinkOpts -> UnitLinkOpts -> UnitLinkOpts
<> (UnitLinkOpts [[Char]]
l2 [[Char]]
el2 [[Char]]
of2) = ([[Char]] -> [[Char]] -> [[Char]] -> UnitLinkOpts
UnitLinkOpts ([[Char]]
l1 [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
l2) ([[Char]]
el1 [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
el2) ([[Char]]
of1 [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
of2))

instance Monoid UnitLinkOpts where
  mempty :: UnitLinkOpts
mempty = [[Char]] -> [[Char]] -> [[Char]] -> UnitLinkOpts
UnitLinkOpts [] [] []

-- | Find all the link options in these and the preload packages,
-- returning (package hs lib options, extra library options, other flags)
getUnitLinkOpts :: GhcNameVersion -> Ways -> Maybe (ExecutableLinkMode, Bool, Platform) -> UnitEnv -> [UnitId] -> IO UnitLinkOpts
getUnitLinkOpts :: GhcNameVersion
-> Ways
-> Maybe (ExecutableLinkMode, Bool, Platform)
-> UnitEnv
-> [UnitId]
-> IO UnitLinkOpts
getUnitLinkOpts GhcNameVersion
namever Ways
ways Maybe (ExecutableLinkMode, Bool, Platform)
mExecutableLinkMode UnitEnv
unit_env [UnitId]
pkgs = do
    ps <- MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo]
forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo])
-> MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo]
forall a b. (a -> b) -> a -> b
$ UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo' UnitEnv
unit_env [UnitId]
pkgs
    collectLinkOpts namever ways mExecutableLinkMode ps

collectLinkOpts :: GhcNameVersion -> Ways -> Maybe (ExecutableLinkMode, Bool, Platform) -> [UnitInfo] -> IO UnitLinkOpts
collectLinkOpts :: GhcNameVersion
-> Ways
-> Maybe (ExecutableLinkMode, Bool, Platform)
-> [UnitInfo]
-> IO UnitLinkOpts
collectLinkOpts GhcNameVersion
namever Ways
ways Maybe (ExecutableLinkMode, Bool, Platform)
mExecutableLinkMode [UnitInfo]
ps = do
  ([UnitLinkOpts] -> UnitLinkOpts)
-> IO [UnitLinkOpts] -> IO UnitLinkOpts
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [UnitLinkOpts] -> UnitLinkOpts
forall a. Monoid a => [a] -> a
mconcat (IO [UnitLinkOpts] -> IO UnitLinkOpts)
-> IO [UnitLinkOpts] -> IO UnitLinkOpts
forall a b. (a -> b) -> a -> b
$ [UnitInfo] -> (UnitInfo -> IO UnitLinkOpts) -> IO [UnitLinkOpts]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnitInfo]
ps ((UnitInfo -> IO UnitLinkOpts) -> IO [UnitLinkOpts])
-> (UnitInfo -> IO UnitLinkOpts) -> IO [UnitLinkOpts]
forall a b. (a -> b) -> a -> b
$ \UnitInfo
pc -> do
    extraLibs <- UnitInfo -> IO [[Char]]
getExtraLibs UnitInfo
pc
    pure UnitLinkOpts
      { hsLibs     = map ("-l" ++) . unitHsLibs namever ways $ pc
      , extraLibs  = extraLibs
      , otherFlags = map ST.unpack . unitLinkerOptions $ pc
      }
 where
  -- extra libs can be represented in different ways, depending on the platform and how we link:
  --   * static linking on most system: -l:libfoo.a -l:libbar.a
  --   * static linking on e.g. mac: /some/path/libfoo.a /some/path/libbar.a
  --   * dynamic linking: -lfoo -lbar
  getExtraLibs :: UnitInfo -> IO [[Char]]
getExtraLibs UnitInfo
pc
    -- We don't do anything here for 'FullyStatic', because appending '-static' to the linker is enough.
    | Just (MostlyStatic Maybe [[Char]]
mExclLibs, Bool
supportsVerbatim, Platform
targetPlatform) <- Maybe (ExecutableLinkMode, Bool, Platform)
mExecutableLinkMode
    , [[Char]]
exclLibs <- Maybe [[Char]] -> Platform -> [[Char]]
mostlyStaticExclude Maybe [[Char]]
mExclLibs Platform
targetPlatform
    = do
        let allLibs :: [[Char]]
allLibs = (ShortText -> [Char]) -> [ShortText] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> [Char]
ST.unpack ([ShortText] -> [[Char]])
-> (UnitInfo -> [ShortText]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepLibsStaticSys (UnitInfo -> [[Char]]) -> UnitInfo -> [[Char]]
forall a b. (a -> b) -> a -> b
$ UnitInfo
pc
            staticLibs :: [[Char]]
staticLibs = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
exclLibs) [[Char]]
allLibs
            dynamicLibs :: [[Char]]
dynamicLibs = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
exclLibs) [[Char]]
allLibs
            dynamicLinkOpts :: [[Char]]
dynamicLinkOpts = ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"-l" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) [[Char]]
dynamicLibs
        staticLinkOpts <- if Bool
supportsVerbatim
                          then [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
d -> [Char]
"-l:lib" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
d [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
".a") [[Char]]
staticLibs)
                          else do [[Char]] -> ([Char] -> IO [Char]) -> IO [[Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
staticLibs (([Char] -> IO [Char]) -> IO [[Char]])
-> ([Char] -> IO [Char]) -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ \[Char]
l -> do
                                   archives <- ([Char] -> IO Bool) -> [[Char]] -> IO [[Char]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
doesFileExist
                                     [ [Char]
searchPath [Char] -> ShowS
</> ([Char]
"lib" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
l [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
".a")
                                     | [Char]
searchPath <- ([[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]])
-> (UnitInfo -> [[Char]]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull ([[Char]] -> [[Char]])
-> (UnitInfo -> [[Char]]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShortText -> [Char]) -> [ShortText] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> [Char]
ST.unpack ([ShortText] -> [[Char]])
-> (UnitInfo -> [ShortText]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraryDirsStatic (UnitInfo -> [[Char]]) -> UnitInfo -> [[Char]]
forall a b. (a -> b) -> a -> b
$ UnitInfo
pc)
                                     ]
                                   case archives of
                                     [] -> GhcException -> IO [Char]
forall a. GhcException -> IO a
throwGhcExceptionIO ([Char] -> GhcException
[Char] -> GhcException
ProgramError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to find static archive of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
l)
                                     -- prefer the "last" as is the canonical way for linker options
                                     [[Char]]
xs -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
last [[Char]]
xs
        pure (staticLinkOpts ++ dynamicLinkOpts)
    | Just (ExecutableLinkMode
FullyStatic, Bool
_, Platform
_) <- Maybe (ExecutableLinkMode, Bool, Platform)
mExecutableLinkMode
    = [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> IO [[Char]])
-> (UnitInfo -> [[Char]]) -> UnitInfo -> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"-l" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]])
-> (UnitInfo -> [[Char]]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShortText -> [Char]) -> [ShortText] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> [Char]
ST.unpack ([ShortText] -> [[Char]])
-> (UnitInfo -> [ShortText]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepLibsStaticSys (UnitInfo -> IO [[Char]]) -> UnitInfo -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ UnitInfo
pc
    | Bool
otherwise = [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> IO [[Char]])
-> (UnitInfo -> [[Char]]) -> UnitInfo -> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"-l" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]])
-> (UnitInfo -> [[Char]]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShortText -> [Char]) -> [ShortText] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> [Char]
ST.unpack ([ShortText] -> [[Char]])
-> (UnitInfo -> [ShortText]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepLibsSys (UnitInfo -> IO [[Char]]) -> UnitInfo -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ UnitInfo
pc

collectArchives :: GhcNameVersion -> Ways -> UnitInfo -> IO [FilePath]
collectArchives :: GhcNameVersion -> Ways -> UnitInfo -> IO [[Char]]
collectArchives GhcNameVersion
namever Ways
ways UnitInfo
pc =
  ([Char] -> IO Bool) -> [[Char]] -> IO [[Char]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
doesFileExist [ [Char]
searchPath [Char] -> ShowS
</> ([Char]
"lib" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
lib [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
".a")
                        | [Char]
searchPath <- [[Char]]
searchPaths
                        , [Char]
lib <- [[Char]]
libs ]
  where searchPaths :: [[Char]]
searchPaths = [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
ordNub ([[Char]] -> [[Char]])
-> (UnitInfo -> [[Char]]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull ([[Char]] -> [[Char]])
-> (UnitInfo -> [[Char]]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ways -> UnitInfo -> [[Char]]
libraryDirsForWay Ways
ways (UnitInfo -> [[Char]]) -> UnitInfo -> [[Char]]
forall a b. (a -> b) -> a -> b
$ UnitInfo
pc
        libs :: [[Char]]
libs        = GhcNameVersion -> Ways -> UnitInfo -> [[Char]]
unitHsLibs GhcNameVersion
namever Ways
ways UnitInfo
pc [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ((ShortText -> [Char]) -> [ShortText] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> [Char]
ST.unpack ([ShortText] -> [[Char]])
-> (UnitInfo -> [ShortText]) -> UnitInfo -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepLibsStaticSys (UnitInfo -> [[Char]]) -> UnitInfo -> [[Char]]
forall a b. (a -> b) -> a -> b
$ UnitInfo
pc)

getLibs :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO [(String,String)]
getLibs :: GhcNameVersion
-> Ways -> UnitEnv -> [UnitId] -> IO [([Char], [Char])]
getLibs GhcNameVersion
namever Ways
ways UnitEnv
unit_env [UnitId]
pkgs = do
  ps <- MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo]
forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo])
-> MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo]
forall a b. (a -> b) -> a -> b
$ UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo' UnitEnv
unit_env [UnitId]
pkgs
  fmap concat . forM ps $ \UnitInfo
p -> do
    let candidates :: [([Char], [Char])]
candidates = [ ([Char]
l [Char] -> ShowS
</> [Char]
f, [Char]
f) | [Char]
l <- Ways -> [UnitInfo] -> [[Char]]
collectLibraryDirs Ways
ways [UnitInfo
p]
                                    , [Char]
f <- (\[Char]
n -> [Char]
"lib" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
".a") ShowS -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GhcNameVersion -> Ways -> UnitInfo -> [[Char]]
unitHsLibs GhcNameVersion
namever Ways
ways UnitInfo
p ]
    (([Char], [Char]) -> IO Bool)
-> [([Char], [Char])] -> IO [([Char], [Char])]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ([Char] -> IO Bool
doesFileExist ([Char] -> IO Bool)
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst) [([Char], [Char])]
candidates

getUnitDepends :: HasDebugCallStack => UnitEnv -> UnitId -> [UnitId]
getUnitDepends :: HasDebugCallStack => UnitEnv -> UnitId -> [UnitId]
getUnitDepends UnitEnv
unit_env UnitId
pkg =
    let unit_state :: UnitState
unit_state = HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_homeUnitState UnitEnv
unit_env
        unit_info :: UnitInfo
unit_info = HasDebugCallStack => UnitState -> UnitId -> UnitInfo
UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId UnitState
unit_state UnitId
pkg
    in (UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
unit_info)