aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/CabalHelper/Compiletime/Cabal.hs9
-rw-r--r--src/CabalHelper/Compiletime/CompPrograms.hs99
-rw-r--r--src/CabalHelper/Compiletime/Types.hs7
3 files changed, 114 insertions, 1 deletions
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