Skip to content

Commit

Permalink
Revert "Merge pull request #4874 from zw3rk/feature/basedir"
Browse files Browse the repository at this point in the history 
This reverts commit 783cbe6, reversing
changes made to c094940.
  • Loading branch information
@23Skidoo
23Skidoo committed Mar 2, 2018
1 parent c63d3bd commit caca78a
Show file tree
Hide file tree
Showing 15 changed files with 81 additions and 232 deletions.
1 change: 0 additions & 1 deletion Cabal/Cabal.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -213,7 +213,6 @@ library
Distribution.Utils.LogProgress
Distribution.Utils.MapAccum
Distribution.Compat.CreatePipe
Distribution.Compat.Directory
Distribution.Compat.Environment
Distribution.Compat.Exception
Distribution.Compat.Graph
Expand Down
27 changes: 0 additions & 27 deletions Cabal/Distribution/Compat/Directory.hs
View file

This file was deleted.

109 changes: 36 additions & 73 deletions Cabal/Distribution/Simple.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

Expand Down Expand Up @@ -58,7 +59,6 @@ module Distribution.Simple (
) where

import Prelude ()
import Control.Exception (try)
import Distribution.Compat.Prelude

-- local
Expand Down Expand Up @@ -99,8 +99,7 @@ import System.Environment (getArgs, getProgName)
import System.Directory (removeFile, doesFileExist
,doesDirectoryExist, removeDirectoryRecursive)
import System.Exit (exitWith,ExitCode(..))
import System.FilePath (searchPathSeparator, takeDirectory, (</>))
import Distribution.Compat.Directory (makeAbsolute)
import System.FilePath (searchPathSeparator)
import Distribution.Compat.Environment (getEnvironment)
import Distribution.Compat.GetShortPathName (getShortPathName)

Expand Down Expand Up @@ -249,10 +248,9 @@ buildAction :: UserHooks -> BuildFlags -> Args -> IO ()
buildAction hooks flags args = do
distPref <- findDistPrefOrDefault (buildDistPref flags)
let verbosity = fromFlag $ buildVerbosity flags
lbi <- getBuildConfig hooks verbosity distPref
let flags' = flags { buildDistPref = toFlag distPref
, buildCabalFilePath = maybeToFlag (cabalFilePath lbi)}
flags' = flags { buildDistPref = toFlag distPref }

lbi <- getBuildConfig hooks verbosity distPref
progs <- reconfigurePrograms verbosity
(buildProgramPaths flags')
(buildProgramArgs flags')
Expand Down Expand Up @@ -290,10 +288,7 @@ hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()
hscolourAction hooks flags args = do
distPref <- findDistPrefOrDefault (hscolourDistPref flags)
let verbosity = fromFlag $ hscolourVerbosity flags
lbi <- getBuildConfig hooks verbosity distPref
let flags' = flags { hscolourDistPref = toFlag distPref
, hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi)}

flags' = flags { hscolourDistPref = toFlag distPref }
hookedAction preHscolour hscolourHook postHscolour
(getBuildConfig hooks verbosity distPref)
hooks flags' args
Expand All @@ -318,10 +313,9 @@ haddockAction :: UserHooks -> HaddockFlags -> Args -> IO ()
haddockAction hooks flags args = do
distPref <- findDistPrefOrDefault (haddockDistPref flags)
let verbosity = fromFlag $ haddockVerbosity flags
lbi <- getBuildConfig hooks verbosity distPref
let flags' = flags { haddockDistPref = toFlag distPref
, haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)}
flags' = flags { haddockDistPref = toFlag distPref }

lbi <- getBuildConfig hooks verbosity distPref
progs <- reconfigurePrograms verbosity
(haddockProgramPaths flags')
(haddockProgramArgs flags')
Expand All @@ -334,12 +328,7 @@ haddockAction hooks flags args = do
cleanAction :: UserHooks -> CleanFlags -> Args -> IO ()
cleanAction hooks flags args = do
distPref <- findDistPrefOrDefault (cleanDistPref flags)

elbi <- tryGetBuildConfig hooks verbosity distPref
let flags' = flags { cleanDistPref = toFlag distPref
, cleanCabalFilePath = case elbi of
Left _ -> mempty
Right lbi -> maybeToFlag (cabalFilePath lbi)}
let flags' = flags { cleanDistPref = toFlag distPref }

pbi <- preClean hooks args flags'

Expand All @@ -365,9 +354,7 @@ copyAction :: UserHooks -> CopyFlags -> Args -> IO ()
copyAction hooks flags args = do
distPref <- findDistPrefOrDefault (copyDistPref flags)
let verbosity = fromFlag $ copyVerbosity flags
lbi <- getBuildConfig hooks verbosity distPref
let flags' = flags { copyDistPref = toFlag distPref
, copyCabalFilePath = maybeToFlag (cabalFilePath lbi)}
flags' = flags { copyDistPref = toFlag distPref }
hookedAction preCopy copyHook postCopy
(getBuildConfig hooks verbosity distPref)
hooks flags' { copyArgs = args } args
Expand All @@ -376,9 +363,7 @@ installAction :: UserHooks -> InstallFlags -> Args -> IO ()
installAction hooks flags args = do
distPref <- findDistPrefOrDefault (installDistPref flags)
let verbosity = fromFlag $ installVerbosity flags
lbi <- getBuildConfig hooks verbosity distPref
let flags' = flags { installDistPref = toFlag distPref
, installCabalFilePath = maybeToFlag (cabalFilePath lbi)}
flags' = flags { installDistPref = toFlag distPref }
hookedAction preInst instHook postInst
(getBuildConfig hooks verbosity distPref)
hooks flags' args
Expand Down Expand Up @@ -442,9 +427,7 @@ registerAction :: UserHooks -> RegisterFlags -> Args -> IO ()
registerAction hooks flags args = do
distPref <- findDistPrefOrDefault (regDistPref flags)
let verbosity = fromFlag $ regVerbosity flags
lbi <- getBuildConfig hooks verbosity distPref
let flags' = flags { regDistPref = toFlag distPref
, regCabalFilePath = maybeToFlag (cabalFilePath lbi)}
flags' = flags { regDistPref = toFlag distPref }
hookedAction preReg regHook postReg
(getBuildConfig hooks verbosity distPref)
hooks flags' { regArgs = args } args
Expand All @@ -453,9 +436,7 @@ unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO ()
unregisterAction hooks flags args = do
distPref <- findDistPrefOrDefault (regDistPref flags)
let verbosity = fromFlag $ regVerbosity flags
lbi <- getBuildConfig hooks verbosity distPref
let flags' = flags { regDistPref = toFlag distPref
, regCabalFilePath = maybeToFlag (cabalFilePath lbi)}
flags' = flags { regDistPref = toFlag distPref }
hookedAction preUnreg unregHook postUnreg
(getBuildConfig hooks verbosity distPref)
hooks flags' args
Expand Down Expand Up @@ -506,13 +487,7 @@ sanityCheckHookedBuildInfo pkg_descr (_, hookExes)

sanityCheckHookedBuildInfo _ _ = return ()

-- | Try to read the 'localBuildInfoFile'
tryGetBuildConfig :: UserHooks -> Verbosity -> FilePath
-> IO (Either ConfigStateFileError LocalBuildInfo)
tryGetBuildConfig u v = try . getBuildConfig u v


-- | Read the 'localBuildInfoFile' or throw an exception.
getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo
getBuildConfig hooks verbosity distPref = do
lbi_wo_programs <- getPersistBuildConfig distPref
Expand Down Expand Up @@ -643,14 +618,12 @@ defaultUserHooks = autoconfUserHooks {
-- https://github.com/haskell/cabal/issues/158
where oldCompatPostConf args flags pkg_descr lbi
= do let verbosity = fromFlag (configVerbosity flags)
baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi')

confExists <- doesFileExist $ (baseDir lbi) </> "configure"
confExists <- doesFileExist "configure"
when confExists $
runConfigureScript verbosity
backwardsCompatHack flags lbi

pbi <- getHookedBuildInfo (buildDir lbi) verbosity
pbi <- getHookedBuildInfo verbosity
sanityCheckHookedBuildInfo pkg_descr pbi
let pkg_descr' = updatePackageDescription pbi pkg_descr
lbi' = lbi { localPkgDescr = pkg_descr' }
Expand All @@ -663,51 +636,44 @@ autoconfUserHooks
= simpleUserHooks
{
postConf = defaultPostConf,
preBuild = readHookWithArgs buildVerbosity buildDistPref, -- buildCabalFilePath,
preCopy = readHookWithArgs copyVerbosity copyDistPref,
preClean = readHook cleanVerbosity cleanDistPref,
preInst = readHook installVerbosity installDistPref,
preHscolour = readHook hscolourVerbosity hscolourDistPref,
preHaddock = readHook haddockVerbosity haddockDistPref,
preReg = readHook regVerbosity regDistPref,
preUnreg = readHook regVerbosity regDistPref
preBuild = readHookWithArgs buildVerbosity,
preCopy = readHookWithArgs copyVerbosity,
preClean = readHook cleanVerbosity,
preInst = readHook installVerbosity,
preHscolour = readHook hscolourVerbosity,
preHaddock = readHook haddockVerbosity,
preReg = readHook regVerbosity,
preUnreg = readHook regVerbosity
}
where defaultPostConf :: Args -> ConfigFlags -> PackageDescription
-> LocalBuildInfo -> IO ()
defaultPostConf args flags pkg_descr lbi
= do let verbosity = fromFlag (configVerbosity flags)
baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi')
confExists <- doesFileExist $ (baseDir lbi) </> "configure"
confExists <- doesFileExist "configure"
if confExists
then runConfigureScript verbosity
backwardsCompatHack flags lbi
else die "configure script not found."

pbi <- getHookedBuildInfo (buildDir lbi) verbosity
pbi <- getHookedBuildInfo verbosity
sanityCheckHookedBuildInfo pkg_descr pbi
let pkg_descr' = updatePackageDescription pbi pkg_descr
lbi' = lbi { localPkgDescr = pkg_descr' }
postConf simpleUserHooks args flags pkg_descr' lbi'

backwardsCompatHack = False

readHookWithArgs :: (a -> Flag Verbosity)
-> (a -> Flag FilePath)
-> Args -> a
readHookWithArgs :: (a -> Flag Verbosity) -> Args -> a
-> IO HookedBuildInfo
readHookWithArgs get_verbosity get_dist_pref _ flags = do
dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
getHookedBuildInfo (dist_dir </> "build") verbosity
readHookWithArgs get_verbosity _ flags = do
getHookedBuildInfo verbosity
where
verbosity = fromFlag (get_verbosity flags)

readHook :: (a -> Flag Verbosity)
-> (a -> Flag FilePath)
-> Args -> a -> IO HookedBuildInfo
readHook get_verbosity get_dist_pref a flags = do
readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo
readHook get_verbosity a flags = do
noExtraFlags a
dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
getHookedBuildInfo (dist_dir </> "build") verbosity
getHookedBuildInfo verbosity
where
verbosity = fromFlag (get_verbosity flags)

Expand All @@ -724,8 +690,6 @@ runConfigureScript verbosity backwardsCompatHack flags lbi = do
-- 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
configureFile <- makeAbsolute $
fromMaybe "." (takeDirectory <$> cabalFilePath lbi) </> "configure"
let extraPath = fromNubList $ configProgramPathExtra flags
let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags))
$ lookup "CFLAGS" env
Expand All @@ -734,30 +698,29 @@ runConfigureScript verbosity backwardsCompatHack flags lbi = do
((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env
overEnv = ("CFLAGS", Just cflagsEnv) :
[("PATH", Just pathEnv) | not (null extraPath)]
args' = configureFile:args ++ ["CC=" ++ ccProgShort]
args' = args ++ ["CC=" ++ ccProgShort]
shProg = simpleProgram "sh"
progDb = modifyProgramSearchPath
(\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
shConfiguredProg <- lookupProgram shProg
`fmap` configureProgram verbosity shProg progDb
case shConfiguredProg of
Just sh -> runProgramInvocation verbosity $
Just sh -> runProgramInvocation verbosity
(programInvocation (sh {programOverrideEnv = overEnv}) args')
{ progInvokeCwd = Just (buildDir lbi) }
Nothing -> die notFoundMsg

where
args = configureArgs backwardsCompatHack flags
args = "./configure" : configureArgs backwardsCompatHack flags

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

getHookedBuildInfo :: FilePath -> Verbosity -> IO HookedBuildInfo
getHookedBuildInfo build_dir verbosity = do
maybe_infoFile <- findHookedPackageDesc build_dir
getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo
getHookedBuildInfo verbosity = do
maybe_infoFile <- defaultHookedPackageDesc
case maybe_infoFile of
Nothing -> return emptyHookedBuildInfo
Just infoFile -> do
Expand Down
Loading

0 comments on commit caca78a

Please sign in to comment.