module Distribution.Simple.GHC.Build.Utils where

import Distribution.Compat.Prelude
import Prelude ()

import Control.Monad (msum)
import Data.Char (isLower)
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import Distribution.PackageDescription as PD
import Distribution.PackageDescription.Utils (cabalBug)
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import qualified Distribution.Simple.GHC.Internal as Internal
import Distribution.Simple.Program.GHC
import Distribution.Simple.Setup.Common
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.LocalBuildInfo
import Distribution.Utils.Path (getSymbolicPath)
import Distribution.Verbosity
import System.FilePath
  ( replaceExtension
  , takeExtension
  , (<.>)
  , (</>)
  )

-- | Find the path to the entry point of an executable (typically specified in
-- @main-is@, and found in @hs-source-dirs@).
findExecutableMain
  :: Verbosity
  -> FilePath
  -- ^ Build directory
  -> (BuildInfo, FilePath)
  -- ^ The build info and module path of an executable-like component (Exe, Test, Bench)
  -> IO FilePath
  -- ^ The path to the main source file.
findExecutableMain :: Verbosity -> String -> (BuildInfo, String) -> IO String
findExecutableMain Verbosity
verbosity String
bdir (BuildInfo
bnfo, String
modPath) =
  Verbosity -> [String] -> String -> IO String
findFileEx Verbosity
verbosity (String
bdir String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
bnfo)) String
modPath

-- | Does this compiler support the @-dynamic-too@ option
supportsDynamicToo :: Compiler -> Bool
supportsDynamicToo :: Compiler -> Bool
supportsDynamicToo = String -> Compiler -> Bool
Internal.ghcLookupProperty String
"Support dynamic-too"

-- | Is this compiler's RTS dynamically linked?
isDynamic :: Compiler -> Bool
isDynamic :: Compiler -> Bool
isDynamic = String -> Compiler -> Bool
Internal.ghcLookupProperty String
"GHC Dynamic"

-- | Should we dynamically link the foreign library, based on its 'foreignLibType'?
withDynFLib :: ForeignLib -> Bool
withDynFLib :: ForeignLib -> Bool
withDynFLib ForeignLib
flib =
  case ForeignLib -> ForeignLibType
foreignLibType ForeignLib
flib of
    ForeignLibType
ForeignLibNativeShared ->
      ForeignLibOption
ForeignLibStandalone ForeignLibOption -> [ForeignLibOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ForeignLib -> [ForeignLibOption]
foreignLibOptions ForeignLib
flib
    ForeignLibType
ForeignLibNativeStatic ->
      Bool
False
    ForeignLibType
ForeignLibTypeUnknown ->
      String -> Bool
forall a. String -> a
cabalBug String
"unknown foreign lib type"

-- | Is this file a C++ source file, i.e. ends with .cpp, .cxx, or .c++?
isCxx :: FilePath -> Bool
isCxx :: String -> Bool
isCxx String
fp = String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String -> String
takeExtension String
fp) [String
".cpp", String
".cxx", String
".c++"]

-- | Is this a C source file, i.e. ends with .c?
isC :: FilePath -> Bool
isC :: String -> Bool
isC String
fp = String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String -> String
takeExtension String
fp) [String
".c"]

-- | FilePath has a Haskell extension: .hs or .lhs
isHaskell :: FilePath -> Bool
isHaskell :: String -> Bool
isHaskell String
fp = String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String -> String
takeExtension String
fp) [String
".hs", String
".lhs"]

-- | Returns True if the modification date of the given source file is newer than
-- the object file we last compiled for it, or if no object file exists yet.
checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool
checkNeedsRecompilation :: String -> GhcOptions -> IO Bool
checkNeedsRecompilation String
filename GhcOptions
opts = String
filename String -> String -> IO Bool
`moreRecentFile` String
oname
  where
    oname :: String
oname = String -> GhcOptions -> String
getObjectFileName String
filename GhcOptions
opts

-- | Finds the object file name of the given source file
getObjectFileName :: FilePath -> GhcOptions -> FilePath
getObjectFileName :: String -> GhcOptions -> String
getObjectFileName String
filename GhcOptions
opts = String
oname
  where
    odir :: String
odir = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (GhcOptions -> Flag String
ghcOptObjDir GhcOptions
opts)
    oext :: String
oext = String -> Flag String -> String
forall a. a -> Flag a -> a
fromFlagOrDefault String
"o" (GhcOptions -> Flag String
ghcOptObjSuffix GhcOptions
opts)
    oname :: String
oname = String
odir String -> String -> String
</> String -> String -> String
replaceExtension String
filename String
oext

-- | Target name for a foreign library (the actual file name)
--
-- We do not use mkLibName and co here because the naming for foreign libraries
-- is slightly different (we don't use "_p" or compiler version suffices, and we
-- don't want the "lib" prefix on Windows).
--
-- TODO: We do use `dllExtension` and co here, but really that's wrong: they
-- use the OS used to build cabal to determine which extension to use, rather
-- than the target OS (but this is wrong elsewhere in Cabal as well).
flibTargetName :: LocalBuildInfo -> ForeignLib -> String
flibTargetName :: LocalBuildInfo -> ForeignLib -> String
flibTargetName LocalBuildInfo
lbi ForeignLib
flib =
  case (OS
os, ForeignLib -> ForeignLibType
foreignLibType ForeignLib
flib) of
    (OS
Windows, ForeignLibType
ForeignLibNativeShared) -> String
nm String -> String -> String
<.> String
"dll"
    (OS
Windows, ForeignLibType
ForeignLibNativeStatic) -> String
nm String -> String -> String
<.> String
"lib"
    (OS
Linux, ForeignLibType
ForeignLibNativeShared) -> String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
<.> String
versionedExt
    (OS
_other, ForeignLibType
ForeignLibNativeShared) ->
      String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
<.> Platform -> String
dllExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi)
    (OS
_other, ForeignLibType
ForeignLibNativeStatic) ->
      String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
<.> Platform -> String
staticLibExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi)
    (OS
_any, ForeignLibType
ForeignLibTypeUnknown) -> String -> String
forall a. String -> a
cabalBug String
"unknown foreign lib type"
  where
    nm :: String
    nm :: String
nm = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib

    os :: OS
    Platform Arch
_ OS
os = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi

    -- If a foreign lib foo has lib-version-info 5:1:2 or
    -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1
    -- Libtool's version-info data is translated into library versions in a
    -- nontrivial way: so refer to libtool documentation.
    versionedExt :: String
    versionedExt :: String
versionedExt =
      let nums :: [Int]
nums = ForeignLib -> OS -> [Int]
foreignLibVersion ForeignLib
flib OS
os
       in (String -> String -> String) -> String -> [String] -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl String -> String -> String
(<.>) String
"so" ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show [Int]
nums)

-- | Name for the library when building.
--
-- If the `lib-version-info` field or the `lib-version-linux` field of
-- a foreign library target is set, we need to incorporate that
-- version into the SONAME field.
--
-- If a foreign library foo has lib-version-info 5:1:2, it should be
-- built as libfoo.so.3.2.1.  We want it to get soname libfoo.so.3.
-- However, GHC does not allow overriding soname by setting linker
-- options, as it sets a soname of its own (namely the output
-- filename), after the user-supplied linker options.  Hence, we have
-- to compile the library with the soname as its filename.  We rename
-- the compiled binary afterwards.
--
-- This method allows to adjust the name of the library at build time
-- such that the correct soname can be set.
flibBuildName :: LocalBuildInfo -> ForeignLib -> String
flibBuildName :: LocalBuildInfo -> ForeignLib -> String
flibBuildName LocalBuildInfo
lbi ForeignLib
flib
  -- On linux, if a foreign-library has version data, the first digit is used
  -- to produce the SONAME.
  | (OS
os, ForeignLib -> ForeignLibType
foreignLibType ForeignLib
flib)
      (OS, ForeignLibType) -> (OS, ForeignLibType) -> Bool
forall a. Eq a => a -> a -> Bool
== (OS
Linux, ForeignLibType
ForeignLibNativeShared) =
      let nums :: [Int]
nums = ForeignLib -> OS -> [Int]
foreignLibVersion ForeignLib
flib OS
os
       in String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
<.> (String -> String -> String) -> String -> [String] -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl String -> String -> String
(<.>) String
"so" ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 [Int]
nums))
  | Bool
otherwise = LocalBuildInfo -> ForeignLib -> String
flibTargetName LocalBuildInfo
lbi ForeignLib
flib
  where
    os :: OS
    Platform Arch
_ OS
os = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi

    nm :: String
    nm :: String
nm = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib

-- | Gets the target name (name of actual executable file) from the name of an
-- executable-like component ('Executable', 'TestSuite', 'Benchmark').
exeTargetName :: Platform -> UnqualComponentName -> String
exeTargetName :: Platform -> UnqualComponentName -> String
exeTargetName Platform
platform UnqualComponentName
name = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name String -> String -> String
`withExt` Platform -> String
exeExtension Platform
platform
  where
    withExt :: FilePath -> String -> FilePath
    withExt :: String -> String -> String
withExt String
fp String
ext = String
fp String -> String -> String
<.> if String -> String
takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= (Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
ext) then String
ext else String
""

-- | "Main" module name when overridden by @ghc-options: -main-is ...@
-- or 'Nothing' if no @-main-is@ flag could be found.
--
-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed.
exeMainModuleName
  :: BuildInfo
  -- ^ The build info of the executable-like component (Exe, Test, Bench)
  -> ModuleName
exeMainModuleName :: BuildInfo -> ModuleName
exeMainModuleName BuildInfo
bnfo =
  -- GHC honors the last occurrence of a module name updated via -main-is
  --
  -- Moreover, -main-is when parsed left-to-right can update either
  -- the "Main" module name, or the "main" function name, or both,
  -- see also 'decodeMainIsArg'.
  ModuleName -> Maybe ModuleName -> ModuleName
forall a. a -> Maybe a -> a
fromMaybe ModuleName
ModuleName.main (Maybe ModuleName -> ModuleName) -> Maybe ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Maybe ModuleName] -> Maybe ModuleName
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe ModuleName] -> Maybe ModuleName)
-> [Maybe ModuleName] -> Maybe ModuleName
forall a b. (a -> b) -> a -> b
$ [Maybe ModuleName] -> [Maybe ModuleName]
forall a. [a] -> [a]
reverse ([Maybe ModuleName] -> [Maybe ModuleName])
-> [Maybe ModuleName] -> [Maybe ModuleName]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe ModuleName) -> [String] -> [Maybe ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe ModuleName
decodeMainIsArg ([String] -> [Maybe ModuleName]) -> [String] -> [Maybe ModuleName]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
findIsMainArgs [String]
ghcopts
  where
    ghcopts :: [String]
ghcopts = CompilerFlavor -> BuildInfo -> [String]
hcOptions CompilerFlavor
GHC BuildInfo
bnfo

    findIsMainArgs :: [String] -> [String]
findIsMainArgs [] = []
    findIsMainArgs (String
"-main-is" : String
arg : [String]
rest) = String
arg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
findIsMainArgs [String]
rest
    findIsMainArgs (String
_ : [String]
rest) = [String] -> [String]
findIsMainArgs [String]
rest

-- | Decode argument to '-main-is'
--
-- Returns 'Nothing' if argument set only the function name.
--
-- This code has been stolen/refactored from GHC's DynFlags.setMainIs
-- function. The logic here is deliberately imperfect as it is
-- intended to be bug-compatible with GHC's parser. See discussion in
-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.
decodeMainIsArg :: String -> Maybe ModuleName
decodeMainIsArg :: String -> Maybe ModuleName
decodeMainIsArg String
arg
  | String -> (Char -> Bool) -> Bool
headOf String
main_fn Char -> Bool
isLower =
      -- The arg looked like "Foo.Bar.baz"
      ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (String -> ModuleName
forall a. IsString a => String -> a
ModuleName.fromString String
main_mod)
  | String -> (Char -> Bool) -> Bool
headOf String
arg Char -> Bool
isUpper -- The arg looked like "Foo" or "Foo.Bar"
    =
      ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (String -> ModuleName
forall a. IsString a => String -> a
ModuleName.fromString String
arg)
  | Bool
otherwise -- The arg looked like "baz"
    =
      Maybe ModuleName
forall a. Maybe a
Nothing
  where
    headOf :: String -> (Char -> Bool) -> Bool
    headOf :: String -> (Char -> Bool) -> Bool
headOf String
str Char -> Bool
pred' = (Char -> Bool) -> Maybe Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
pred' (String -> Maybe Char
forall a. [a] -> Maybe a
safeHead String
str)

    (String
main_mod, String
main_fn) = String -> (Char -> Bool) -> (String, String)
splitLongestPrefix String
arg (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')

    splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)
    splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)
splitLongestPrefix String
str Char -> Bool
pred'
      | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
r_pre = (String
str, [])
      | Bool
otherwise = (String -> String
forall a. [a] -> [a]
reverse (String -> String
forall a. [a] -> [a]
safeTail String
r_pre), String -> String
forall a. [a] -> [a]
reverse String
r_suf)
      where
        -- 'safeTail' drops the char satisfying 'pred'
        (String
r_suf, String
r_pre) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
pred' (String -> String
forall a. [a] -> [a]
reverse String
str)