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.

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