    {-# 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"
          progDb :: ProgramDb
    progDb = (ProgramSearchPath -> ProgramSearchPath) -> ProgramDb -> ProgramDb
    modifyProgramSearchPath
                   (\ProgramSearchPath
    p -> (String -> ProgramSearchPathEntry) -> [String] -> ProgramSearchPath
    forall a b. (a -> b) -> [a] -> [b]
    map String -> ProgramSearchPathEntry
    ProgramSearchPathDir [String]
    extraPath ProgramSearchPath -> ProgramSearchPath -> ProgramSearchPath
    forall a. [a] -> [a] -> [a]
    ++ ProgramSearchPath
    p) 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")
      ]