{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.ConfigureScript
-- Copyright   :  Isaac Jones 2003-2005
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Distribution.Simple.ConfigureScript (
    runConfigureScript
  ) where

import Prelude ()
import Distribution.Compat.Prelude

-- local
import Distribution.PackageDescription
import Distribution.Simple.Program
import Distribution.Simple.Program.Db
import Distribution.Simple.Setup

import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Utils.NubList
import Distribution.Verbosity
import Distribution.Pretty
import Distribution.System (buildPlatform)

-- Base
import System.FilePath    (searchPathSeparator, takeDirectory, (</>),
                           splitDirectories, dropDrive)
#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 :: Verbosity -> ConfigFlags -> LocalBuildInfo
                   -> IO ()
runConfigureScript :: Verbosity -> ConfigFlags -> LocalBuildInfo -> IO ()
runConfigureScript Verbosity
verbosity ConfigFlags
flags LocalBuildInfo
lbi = do
  [(String, String)]
env <- IO [(String, String)]
getEnvironment
  let programDb :: ProgramDb
programDb = LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi
  (String
ccProg, [String]
ccFlags) <- Verbosity -> ProgramDb -> IO (String, [String])
configureCCompiler Verbosity
verbosity ProgramDb
programDb
  String
ccProgShort <- String -> IO String
getShortPathName String
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
  String
configureFile <- String -> IO String
makeAbsolute (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
    String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"." (String -> String
takeDirectory (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocalBuildInfo -> Maybe String
cabalFilePath LocalBuildInfo
lbi) String -> String -> String
</> String
"configure"
  -- 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.
  let configureFile' :: String
configureFile' = String -> String
toUnix String
configureFile
  [(Char, String)] -> ((Char, String) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Char, String)]
badAutoconfCharacters (((Char, String) -> IO ()) -> IO ())
-> ((Char, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(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
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 -> 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 :: 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 -> [(FlagName, Bool)])
-> FlagAssignment -> [(FlagName, Bool)]
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> FlagAssignment
flagAssignment LocalBuildInfo
lbi
                     ]
  -- A map from env vars to flag names to the single flag we will go with
  Map String (FlagName, Bool)
cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <-
    ((String -> NonEmpty (FlagName, Bool) -> IO (FlagName, Bool))
 -> Map String (NonEmpty (FlagName, Bool))
 -> IO (Map String (FlagName, Bool)))
-> Map String (NonEmpty (FlagName, Bool))
-> (String -> NonEmpty (FlagName, Bool) -> IO (FlagName, Bool))
-> IO (Map String (FlagName, Bool))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> NonEmpty (FlagName, Bool) -> IO (FlagName, Bool))
-> Map String (NonEmpty (FlagName, Bool))
-> IO (Map String (FlagName, Bool))
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey Map String (NonEmpty (FlagName, Bool))
cabalFlagMap ((String -> NonEmpty (FlagName, Bool) -> IO (FlagName, Bool))
 -> IO (Map String (FlagName, Bool)))
-> (String -> NonEmpty (FlagName, Bool) -> IO (FlagName, Bool))
-> IO (Map String (FlagName, Bool))
forall a b. (a -> b) -> a -> b
$ \ 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, Maybe String)]
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 -> [(FlagName, Bool)])
-> FlagAssignment -> [(FlagName, Bool)]
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> FlagAssignment
flagAssignment LocalBuildInfo
lbi ]
                       )
                     ]
  let extraPath :: [String]
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
flags
  let cflagsEnv :: String
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 :: String
spSep = [Char
searchPathSeparator]
      pathEnv :: String
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, Maybe String)]
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
      hp :: Platform
hp = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
      maybeHostFlag :: [String]
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]
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 :: Program
shProg = String -> Program
simpleProgram String
"sh"
  ProgramDb
progDb <- Verbosity -> [String] -> ProgramDb -> IO ProgramDb
appendProgramSearchPath Verbosity
verbosity [String]
extraPath ProgramDb
emptyProgramDb
  Maybe ConfiguredProgram
shConfiguredProg <- Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
shProg
                      (ProgramDb -> Maybe ConfiguredProgram)
-> IO ProgramDb -> IO (Maybe ConfiguredProgram)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> Program -> ProgramDb -> IO ProgramDb
configureProgram Verbosity
verbosity Program
shProg ProgramDb
progDb
  case Maybe ConfiguredProgram
shConfiguredProg of
      Just ConfiguredProgram
sh -> 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 (buildDir lbi) }
      Maybe ConfiguredProgram
Nothing -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
notFoundMsg
  where
    args :: [String]
args = Bool -> ConfigFlags -> [String]
configureArgs Bool
backwardsCompatHack ConfigFlags
flags
    backwardsCompatHack :: Bool
backwardsCompatHack = Bool
False

    notFoundMsg :: String
notFoundMsg = String
"The package has a './configure' script. "
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"If you are on Windows, This requires a "
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"If you are not on Windows, ensure that an 'sh' command "
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"is discoverable in your path."

-- | 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 = 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]
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")
  ]