Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

basedir #4874

Merged
merged 6 commits into from
Feb 14, 2018
Merged

basedir #4874

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
8d88dd9
Adds tryGetBuildInfo
angerman Feb 7, 2018
af49513
Read basedir from cabal-file, and thread it through apropriately.
angerman Nov 7, 2017
3a9830b
Check for duplicate files generated by `configure` and shipped with t…
angerman Feb 8, 2018
767efff
Cleanup directory compat
angerman Feb 8, 2018
3ebb984
Move compat bits for 'directory' to D.Compat.Directory.
23Skidoo Feb 13, 2018
f69ef8d
Comments only.
23Skidoo Feb 13, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions Cabal/Cabal.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -206,6 +206,7 @@ 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: 27 additions & 0 deletions Cabal/Distribution/Compat/Directory.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,27 @@
{-# LANGUAGE CPP #-}

module Distribution.Compat.Directory (listDirectory, makeAbsolute) where

import System.Directory as Dir
#if !MIN_VERSION_directory(1,2,2)
import System.FilePath as Path
#endif

#if !MIN_VERSION_directory(1,2,5)

listDirectory :: FilePath -> IO [FilePath]
listDirectory path =
filter f <$> Dir.getDirectoryContents path
where f filename = filename /= "." && filename /= ".."

#endif

#if !MIN_VERSION_directory(1,2,2)

makeAbsolute :: FilePath -> IO FilePath
makeAbsolute p | Path.isAbsolute p = return p
| otherwise = do
cwd <- Dir.getCurrentDirectory
return $ cwd </> p

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

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

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

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

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

lbi <- getBuildConfig hooks verbosity distPref
let flags' = flags { buildDistPref = toFlag distPref
, buildCabalFilePath = maybeToFlag (cabalFilePath lbi)}

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

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

lbi <- getBuildConfig hooks verbosity distPref
let flags' = flags { haddockDistPref = toFlag distPref
, haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)}

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

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

pbi <- preClean hooks args flags'

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

sanityCheckHookedBuildInfo _ _ = return ()

-- | Try to read the 'localBuildInfoFile'
tryGetBuildConfig :: UserHooks -> Verbosity -> FilePath
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Weird, I was quite sure we already had this function somewhere...

-> 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 @@ -618,12 +643,14 @@ defaultUserHooks = autoconfUserHooks {
-- https://github.com/haskell/cabal/issues/158
where oldCompatPostConf args flags pkg_descr lbi
= do let verbosity = fromFlag (configVerbosity flags)
confExists <- doesFileExist "configure"
baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi')

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

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

pbi <- getHookedBuildInfo verbosity
pbi <- getHookedBuildInfo (buildDir lbi) 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) -> Args -> a
readHookWithArgs :: (a -> Flag Verbosity)
-> (a -> Flag FilePath)
-> Args -> a
-> IO HookedBuildInfo
readHookWithArgs get_verbosity _ flags = do
getHookedBuildInfo verbosity
readHookWithArgs get_verbosity get_dist_pref _ flags = do
dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
getHookedBuildInfo (dist_dir </> "build") verbosity
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm not totally keen on the fact that we're hardcoding "build" everywhere. This works with new-build directory structure, right?

where
verbosity = fromFlag (get_verbosity flags)

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

Expand All @@ -690,6 +724,8 @@ 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 @@ -698,29 +734,30 @@ runConfigureScript verbosity backwardsCompatHack flags lbi = do
((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env
overEnv = ("CFLAGS", Just cflagsEnv) :
[("PATH", Just pathEnv) | not (null extraPath)]
args' = args ++ ["CC=" ++ ccProgShort]
args' = configureFile: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 = "./configure" : configureArgs backwardsCompatHack flags
args = 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 :: Verbosity -> IO HookedBuildInfo
getHookedBuildInfo verbosity = do
maybe_infoFile <- defaultHookedPackageDesc
getHookedBuildInfo :: FilePath -> Verbosity -> IO HookedBuildInfo
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We should mention in the changelog/migration guide that this function has changed type.

getHookedBuildInfo build_dir verbosity = do
maybe_infoFile <- findHookedPackageDesc build_dir
case maybe_infoFile of
Nothing -> return emptyHookedBuildInfo
Just infoFile -> do
Expand Down
Loading