1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
{-# LANGUAGE GADTs #-}
module CabalHelper.Compiletime.CompPrograms where
import Control.Monad (when)
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 CabalHelper.Shared.Common (panicIO)
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 True bindir $ ghcProgram progs
createProgSymlink True bindir $ ghcPkgProgram progs
createProgSymlink False bindir $ haddockProgram progs
return $ progs
{ stackEnv =
[("PATH", EnvPrepend $ bindir ++ [searchPathSeparator])] ++
stackEnv progs
}
createProgSymlink :: Bool -> FilePath -> FilePath -> IO ()
createProgSymlink required bindir target
| [exe] <- splitPath target = do
mb_exe_path <- findExecutable exe
case mb_exe_path of
Just exe_path -> createSymbolicLink exe_path (bindir </> takeFileName target)
Nothing -> when required $ panicIO $ "Error trying to create symlink to '" ++ target ++ "': "
++ "'" ++ exe ++ "'" ++ " executable not found."
| otherwise = do
cwd <- getCurrentDirectory
createSymbolicLink (cwd </> target) (bindir </> takeFileName target)
|
