From ca9f53e4133f185f353a6d9e13257cddfd621ec2 Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Wed, 25 Sep 2019 17:09:17 +0200 Subject: Add support for symlink farming as a workaround for Stack We want to be able to have the build tool use exactly the compiler and related executables we choose. Stack doesn't really like that mode of operation and insists on getting everything from PATH itself so this commit adds support for creating a temporary symlink farm to convince Stack to use the executables we want it to use. --- src/CabalHelper/Compiletime/Cabal.hs | 9 +++ src/CabalHelper/Compiletime/CompPrograms.hs | 99 +++++++++++++++++++++++++++++ src/CabalHelper/Compiletime/Types.hs | 7 +- 3 files changed, 114 insertions(+), 1 deletion(-) create mode 100644 src/CabalHelper/Compiletime/CompPrograms.hs (limited to 'src') diff --git a/src/CabalHelper/Compiletime/Cabal.hs b/src/CabalHelper/Compiletime/Cabal.hs index c8afab8..d39761d 100644 --- a/src/CabalHelper/Compiletime/Cabal.hs +++ b/src/CabalHelper/Compiletime/Cabal.hs @@ -37,6 +37,8 @@ import System.FilePath import System.IO import Text.Printf +import Distribution.Verbosity (Verbosity, silent, normal, verbose, deafening) + import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 @@ -285,3 +287,10 @@ parseSetupHeader header = case BS8.words header of <*> parsePkgIdBS setupId <*> parsePkgIdBS compId _ -> Nothing + +getCabalVerbosity :: Verbose => Verbosity +getCabalVerbosity + | ?verbose 2 = normal + | ?verbose 3 = verbose + | ?verbose 4 = deafening + | otherwise = silent diff --git a/src/CabalHelper/Compiletime/CompPrograms.hs b/src/CabalHelper/Compiletime/CompPrograms.hs new file mode 100644 index 0000000..020bab4 --- /dev/null +++ b/src/CabalHelper/Compiletime/CompPrograms.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE GADTs #-} + +module CabalHelper.Compiletime.CompPrograms where + +import Data.List +import Data.Maybe +import System.Directory +import System.FilePath +import System.IO.Temp + +import CabalHelper.Compiletime.Types +import CabalHelper.Compiletime.Cabal (getCabalVerbosity) +import Symlink (createSymbolicLink) + +import Distribution.Simple.GHC as GHC (configure) + +import qualified Distribution.Simple.Program as ProgDb + ( lookupProgram, lookupKnownProgram, programPath + , configureProgram, userMaybeSpecifyPath + , ghcProgram, ghcPkgProgram, haddockProgram ) +import qualified Distribution.Simple.Program.Db as ProgDb + +-- | Determine ghc-pkg/haddock path from ghc path +guessCompProgramPaths :: Verbose => Programs -> IO Programs +guessCompProgramPaths progs = do + let v = getCabalVerbosity + getMaybeProg' = getMaybeProg progs + progdb = + ProgDb.userMaybeSpecifyPath "ghc" (getMaybeProg' ghcProgram) $ + ProgDb.userMaybeSpecifyPath "ghc-pkg" (getMaybeProg' ghcPkgProgram) $ + ProgDb.userMaybeSpecifyPath "haddock" (getMaybeProg' haddockProgram) $ + ProgDb.defaultProgramDb + (_compiler, _mplatform, progdb1) <- GHC.configure v Nothing Nothing progdb + let Just haddockKnownProgram = ProgDb.lookupKnownProgram "haddock" progdb1 + progdb2 <- ProgDb.configureProgram v haddockKnownProgram progdb1 + let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb2 + return progs + { ghcProgram = + fromMaybe (ghcProgram progs) $ getProg ProgDb.ghcProgram + , ghcPkgProgram = + fromMaybe (ghcPkgProgram progs) $ getProg ProgDb.ghcPkgProgram + , haddockProgram = + fromMaybe (haddockProgram progs) $ getProg ProgDb.haddockProgram + } + +getMaybeProg :: Programs -> (Programs -> FilePath) -> Maybe FilePath +getMaybeProg progs fn + | fn progs == fn defaultPrograms = Nothing + | otherwise = Just (fn progs) + +patchBuildToolProgs :: SProjType pt -> Programs -> IO Programs +patchBuildToolProgs (SCabal _) progs = return progs + { cabalUnitArgs = concat + [ maybeToList (("--with-ghc="++) <$> getMaybeProg progs ghcProgram) + , maybeToList (("--with-ghc-pkg="++) <$> getMaybeProg progs ghcPkgProgram) + , maybeToList (("--with-haddock="++) <$> getMaybeProg progs haddockProgram) + ] ++ cabalUnitArgs progs + } +patchBuildToolProgs SStack progs + -- optimization; if none of the program paths are non-default we don't + -- even have to add anything to PATH. + | ghcProgram progs == "ghc" + , ghcPkgProgram progs == "ghc-pkg" + , haddockProgram progs == "haddock" + = return progs + + -- optimization; if all paths are unqualified and have the same version + -- postfix Stack's default behaviour works for us. + | [ghc] <- splitPath (ghcProgram progs) + , [ghcPkg] <- splitPath (ghcPkgProgram progs) + , [haddock] <- splitPath (haddockProgram progs) + , Just ver <- stripPrefix "ghc-" ghc + , Just ver == stripPrefix "ghc-pkg-" ghcPkg + , Just ver == stripPrefix "haddock-" haddock + = return progs +patchBuildToolProgs SStack progs = do + -- otherwise fall back to creating a symlink farm + -- + -- This is of course all quite horrible and we would much prefer just + -- being able to pass executable paths straight through to stack but + -- currently there is no option to let us do that. + withSystemTempDirectory "cabal-helper-symlinks" $ \bindir -> do + createProgSymlink bindir $ ghcProgram progs + createProgSymlink bindir $ ghcPkgProgram progs + createProgSymlink bindir $ haddockProgram progs + return $ progs + { stackEnv = + [("PATH", EnvPrepend $ bindir ++ [searchPathSeparator])] ++ + stackEnv progs + } + +createProgSymlink :: FilePath -> FilePath -> IO () +createProgSymlink bindir target + | [exe] <- splitPath target = do + Just exe_path <- findExecutable exe + createSymbolicLink exe_path (bindir takeFileName target) + | otherwise = do + cwd <- getCurrentDirectory + createSymbolicLink (cwd target) (bindir takeFileName target) diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 6591513..94e5c8e 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -562,12 +562,17 @@ data Programs = Programs , ghcPkgProgram :: !FilePath -- ^ The path to the @ghc-pkg@ program. If not changed it will be derived -- from the path to 'ghcProgram'. + + , haddockProgram :: !FilePath + -- ^ The path to the @haddock@ program. If not changed it will be + -- derived from the path to 'ghcProgram'. } deriving (Eq, Ord, Show, Read, Generic, Typeable) -- | By default all programs use their unqualified names, i.e. they will be -- searched for on @PATH@. defaultPrograms :: Programs -defaultPrograms = Programs "cabal" [] [] "stack" [] [] [] "ghc" "ghc-pkg" +defaultPrograms = + Programs "cabal" [] [] "stack" [] [] [] "ghc" "ghc-pkg" "haddock" data EnvOverride = EnvPrepend String -- cgit v1.2.3