{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -Wno-deprecations #-}

-- |
-- Module      :  Distribution.Simple.ConfigureScript
-- Copyright   :  Isaac Jones 2003-2005
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
module Distribution.Simple.ConfigureScript
  ( runConfigureScript
  ) where

import Distribution.Compat.Prelude
import Prelude ()

-- local
import Distribution.PackageDescription
import Distribution.Pretty
import Distribution.Simple.Configure (findDistPrefOrDefault)
import Distribution.Simple.Errors
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
import Distribution.Simple.Program.Db
import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Config
import Distribution.Simple.Utils
import Distribution.System (Platform, buildPlatform)
import Distribution.Utils.NubList
import Distribution.Utils.Path
import Distribution.Verbosity

-- Base
import System.Directory (createDirectoryIfMissing, doesFileExist, makeAbsolute)
import qualified System.FilePath as FilePath
#ifdef mingw32_HOST_OS
import System.FilePath    (normalise, splitDrive)
#endif
import Distribution.Compat.Environment (getEnvironment)
import Distribution.Compat.GetShortPathName (getShortPathName)

import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map

runConfigureScript
  :: VerbosityHandles
  -> ConfigFlags
  -> FlagAssignment
  -> ProgramDb
  -> Platform
  -- ^ host platform
  -> IO ()
runConfigureScript :: VerbosityHandles
-> ConfigFlags -> FlagAssignment -> ProgramDb -> Platform -> IO ()
runConfigureScript VerbosityHandles
verbHandles ConfigFlags
cfg FlagAssignment
flags ProgramDb
programDb Platform
hp = do
  let commonCfg :: CommonSetupFlags
commonCfg = ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
cfg
      verbosity :: Verbosity
verbosity = VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
verbHandles (Flag VerbosityFlags -> VerbosityFlags
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag VerbosityFlags -> VerbosityFlags)
-> Flag VerbosityFlags -> VerbosityFlags
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag VerbosityFlags
setupVerbosity CommonSetupFlags
commonCfg)
  dist_dir <- Flag (SymbolicPath Pkg ('Dir Dist))
-> IO (SymbolicPath Pkg ('Dir Dist))
findDistPrefOrDefault (Flag (SymbolicPath Pkg ('Dir Dist))
 -> IO (SymbolicPath Pkg ('Dir Dist)))
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> IO (SymbolicPath Pkg ('Dir Dist))
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref CommonSetupFlags
commonCfg
  let build_dir = SymbolicPath Pkg ('Dir Dist)
dist_dir SymbolicPath Pkg ('Dir Dist)
-> RelativePath Dist c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Dist c3
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
"build"
      mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
 -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
setupWorkingDir CommonSetupFlags
commonCfg
      configureScriptPath = CommonSetupFlags -> String
packageRoot CommonSetupFlags
commonCfg String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
"configure"
  confExists <- doesFileExist configureScriptPath
  unless confExists $
    dieWithException verbosity (ConfigureScriptNotFound configureScriptPath)
  configureFile <- makeAbsolute configureScriptPath
  env <- getEnvironment
  (ccProg, ccFlags) <- configureCCompiler verbosity programDb
  ccProgShort <- getShortPathName ccProg
  -- The C compiler's compilation and linker flags (e.g.
  -- "C compiler flags" and "Gcc Linker flags" from GHC) have already
  -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS
  -- to ccFlags
  -- We don't try and tell configure which ld to use, as we don't have
  -- a way to pass its flags too

  -- Do not presume the CXX compiler is available, but it always will be after 9.4.
  (mcxxProgShort, mcxxFlags) <- do
    mprog <- needProgram verbosity gppProgram programDb
    case mprog of
      Just (ConfiguredProgram
p, ProgramDb
_) -> do
        let pInv :: ProgramInvocation
pInv = ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
p []
        let cxxProg :: String
cxxProg = ProgramInvocation -> String
progInvokePath ProgramInvocation
pInv
        let cxxFlags :: [String]
cxxFlags = ProgramInvocation -> [String]
progInvokeArgs ProgramInvocation
pInv
        cxxProgShort <- String -> IO String
getShortPathName String
cxxProg
        return (Just cxxProgShort, Just cxxFlags)
      Maybe (ConfiguredProgram, ProgramDb)
Nothing -> (Maybe String, Maybe [String]) -> IO (Maybe String, Maybe [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
forall a. Maybe a
Nothing, Maybe [String]
forall a. Maybe a
Nothing)

  let configureFile' = String -> String
toUnix String
configureFile
  -- autoconf is fussy about filenames, and has a set of forbidden
  -- characters that can't appear in the build directory, etc:
  -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions
  --
  -- This has caused hard-to-debug failures in the past (#5368), so we
  -- detect some cases early and warn with a clear message. Windows's
  -- use of backslashes is problematic here, so we'll switch to
  -- slashes, but we do still want to fail on backslashes in POSIX
  -- paths.
  --
  -- TODO: We don't check for colons, tildes or leading dashes. We
  -- also should check the builddir's path, destdir, and all other
  -- paths as well.
  for_ badAutoconfCharacters $ \(Char
c, String
cname) ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String -> String
FilePath.dropDrive String
configureFile') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ String
"The path to the './configure' script, '"
          , String
configureFile'
          , String
"', contains the character '"
          , [Char
c]
          , String
"' ("
          , String
cname
          , String
")."
          , String
" This may cause the script to fail with an obscure error, or for"
          , String
" building the package to fail later."
          ]

  let
    -- Convert a flag name to name of environment variable to represent its
    -- value for the configure script.
    flagEnvVar :: FlagName -> String
    flagEnvVar FlagName
flag = String
"CABAL_FLAG_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
f (FlagName -> String
unFlagName FlagName
flag)
      where
        f :: Char -> Char
f Char
c
          | Char -> Bool
isAlphaNum Char
c = Char
c
          | Bool
otherwise = Char
'_'
    -- A map from such env vars to every flag name and value where the name
    -- name maps to that that env var.
    cabalFlagMap :: Map String (NonEmpty (FlagName, Bool))
    cabalFlagMap =
      (NonEmpty (FlagName, Bool)
 -> NonEmpty (FlagName, Bool) -> NonEmpty (FlagName, Bool))
-> [(String, NonEmpty (FlagName, Bool))]
-> Map String (NonEmpty (FlagName, Bool))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
        NonEmpty (FlagName, Bool)
-> NonEmpty (FlagName, Bool) -> NonEmpty (FlagName, Bool)
forall a. Semigroup a => a -> a -> a
(<>)
        [ (FlagName -> String
flagEnvVar FlagName
flag, (FlagName
flag, Bool
bool) (FlagName, Bool) -> [(FlagName, Bool)] -> NonEmpty (FlagName, Bool)
forall a. a -> [a] -> NonEmpty a
:| [])
        | (FlagName
flag, Bool
bool) <- FlagAssignment -> [(FlagName, Bool)]
unFlagAssignment FlagAssignment
flags
        ]
  -- A map from env vars to flag names to the single flag we will go with
  cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <-
    flip Map.traverseWithKey cabalFlagMap $ \String
envVar -> \case
      -- No conflict: no problem
      (FlagName, Bool)
singleFlag :| [] -> (FlagName, Bool) -> IO (FlagName, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FlagName, Bool)
singleFlag
      -- Conflict: warn and discard all but first
      collidingFlags :: NonEmpty (FlagName, Bool)
collidingFlags@((FlagName, Bool)
firstFlag :| (FlagName, Bool)
_ : [(FlagName, Bool)]
_) -> do
        let quote :: String -> String
quote String
s = String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
            toName :: (FlagName, b) -> String
toName = String -> String
quote (String -> String)
-> ((FlagName, b) -> String) -> (FlagName, b) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagName -> String
unFlagName (FlagName -> String)
-> ((FlagName, b) -> FlagName) -> (FlagName, b) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FlagName, b) -> FlagName
forall a b. (a, b) -> a
fst
            renderedList :: String
renderedList = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty String -> [String]) -> NonEmpty String -> [String]
forall a b. (a -> b) -> a -> b
$ (FlagName, Bool) -> String
forall {b}. (FlagName, b) -> String
toName ((FlagName, Bool) -> String)
-> NonEmpty (FlagName, Bool) -> NonEmpty String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (FlagName, Bool)
collidingFlags
        Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unwords
            [ String
"Flags"
            , String
renderedList
            , String
"all map to the same environment variable"
            , String -> String
quote String
envVar
            , String
"causing a collision."
            , String
"The value first flag"
            , (FlagName, Bool) -> String
forall {b}. (FlagName, b) -> String
toName (FlagName, Bool)
firstFlag
            , String
"will be used."
            ]
        (FlagName, Bool) -> IO (FlagName, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FlagName, Bool)
firstFlag

  let cabalFlagEnv =
        [ (String
envVar, String -> Maybe String
forall a. a -> Maybe a
Just String
val)
        | (String
envVar, (FlagName
_, Bool
bool)) <- Map String (FlagName, Bool) -> [(String, (FlagName, Bool))]
forall k a. Map k a -> [(k, a)]
Map.toList Map String (FlagName, Bool)
cabalFlagMapDeconflicted
        , let val :: String
val = if Bool
bool then String
"1" else String
"0"
        ]
          [(String, Maybe String)]
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. [a] -> [a] -> [a]
++ [
               ( String
"CABAL_FLAGS"
               , String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [(FlagName, Bool) -> String
showFlagValue (FlagName, Bool)
fv | (FlagName, Bool)
fv <- FlagAssignment -> [(FlagName, Bool)]
unFlagAssignment FlagAssignment
flags]
               )
             ]
  let extraPath = NubList String -> [String]
forall a. NubList a -> [a]
fromNubList (NubList String -> [String]) -> NubList String -> [String]
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> NubList String
configProgramPathExtra ConfigFlags
cfg
  let mkFlagsEnv [String]
fs String
var = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([String] -> String
unwords [String]
fs) (String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
fs)) (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
var [(String, String)]
env)
      spSep = [Char
FilePath.searchPathSeparator]
      pathEnv =
        String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
spSep [String]
extraPath)
          ((String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
spSep [String]
extraPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
spSep) String -> String -> String
forall a. [a] -> [a] -> [a]
++)
          (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"PATH" [(String, String)]
env
      overEnv =
        (String
"CFLAGS", String -> Maybe String
forall a. a -> Maybe a
Just ([String] -> String -> String
mkFlagsEnv [String]
ccFlags String
"CFLAGS"))
          (String, Maybe String)
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. a -> [a] -> [a]
: [(String
"CXXFLAGS", String -> Maybe String
forall a. a -> Maybe a
Just ([String] -> String -> String
mkFlagsEnv [String]
cxxFlags String
"CXXFLAGS")) | Just [String]
cxxFlags <- [Maybe [String]
mcxxFlags]]
          [(String, Maybe String)]
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. [a] -> [a] -> [a]
++ [(String
"PATH", String -> Maybe String
forall a. a -> Maybe a
Just String
pathEnv) | Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraPath)]
          [(String, Maybe String)]
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. [a] -> [a] -> [a]
++ [(String, Maybe String)]
cabalFlagEnv
      maybeHostFlag = [String
"--host=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (Platform -> Doc
forall a. Pretty a => a -> Doc
pretty Platform
hp) | Platform
hp Platform -> Platform -> Bool
forall a. Eq a => a -> a -> Bool
/= Platform
buildPlatform]
      args' =
        String
configureFile'
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"CC=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ccProgShort]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"CXX=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cxxProgShort | Just String
cxxProgShort <- [Maybe String
mcxxProgShort]]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
maybeHostFlag
      shProg = String -> Program
simpleProgram String
"sh"
  progDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb
  shConfiguredProg <-
    lookupProgram shProg
      `fmap` configureProgram verbosity shProg progDb
  case shConfiguredProg of
    Just ConfiguredProgram
sh -> do
      let build_in :: String
build_in = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
build_dir
      Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
build_in
      Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (ProgramInvocation -> IO ()) -> ProgramInvocation -> IO ()
forall a b. (a -> b) -> a -> b
$
        (ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation (ConfiguredProgram
sh{programOverrideEnv = overEnv}) [String]
args')
          { progInvokeCwd = Just build_in
          }
    Maybe ConfiguredProgram
Nothing -> Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
NotFoundMsg
  where
    args :: [String]
args = Bool -> ConfigFlags -> [String]
configureArgs Bool
backwardsCompatHack ConfigFlags
cfg
    backwardsCompatHack :: Bool
backwardsCompatHack = Bool
False

-- | Convert Windows path to Unix ones
toUnix :: String -> String
#ifdef mingw32_HOST_OS
toUnix s = let tmp = normalise s
               (l, rest) = case splitDrive tmp of
                             ([],  x) -> ("/"      , x)
                             (h:_, x) -> ('/':h:"/", x)
               parts = FilePath.splitDirectories rest
           in  l ++ intercalate "/" parts
#else
toUnix :: String -> String
toUnix String
s = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
FilePath.splitDirectories String
s
#endif

badAutoconfCharacters :: [(Char, String)]
badAutoconfCharacters :: [(Char, String)]
badAutoconfCharacters =
  [ (Char
' ', String
"space")
  , (Char
'\t', String
"tab")
  , (Char
'\n', String
"newline")
  , (Char
'\0', String
"null")
  , (Char
'"', String
"double quote")
  , (Char
'#', String
"hash")
  , (Char
'$', String
"dollar sign")
  , (Char
'&', String
"ampersand")
  , (Char
'\'', String
"single quote")
  , (Char
'(', String
"left bracket")
  , (Char
')', String
"right bracket")
  , (Char
'*', String
"star")
  , (Char
';', String
"semicolon")
  , (Char
'<', String
"less-than sign")
  , (Char
'=', String
"equals sign")
  , (Char
'>', String
"greater-than sign")
  , (Char
'?', String
"question mark")
  , (Char
'[', String
"left square bracket")
  , (Char
'\\', String
"backslash")
  , (Char
'`', String
"backtick")
  , (Char
'|', String
"pipe")
  ]