1 files changed, 99 insertions, 0 deletions
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)