{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-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

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

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

runConfigureScript
  :: ConfigFlags
  -> FlagAssignment
  -> ProgramDb
  -> Platform
  -- ^ host platform
  -> IO ()
runConfigureScript :: ConfigFlags -> FlagAssignment -> ProgramDb -> Platform -> IO ()
runConfigureScript ConfigFlags
cfg FlagAssignment
flags ProgramDb
programDb Platform
hp = do
  let commonCfg :: CommonSetupFlags
commonCfg = ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
cfg
      verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag Verbosity
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

  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 cflagsEnv =
        String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([String] -> String
unwords [String]
ccFlags) (String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
ccFlags)) (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
"CFLAGS" [(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
cflagsEnv)
          (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 = if Platform
hp Platform -> Platform -> Bool
forall a. Eq a => a -> a -> Bool
== Platform
buildPlatform then [] else [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)]
      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]
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, Show a1, Typeable a1,
 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")
  ]