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