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.

8 files changed, 222 insertions, 61 deletions

diff --git a/cabal-helper.cabal b/cabal-helper.cabal
index 384a849..db777ad 100644
--- a/cabal-helper.cabal
+++ b/cabal-helper.cabal
@@ -120,10 +120,13 @@ common build-deps
                      , temporary        < 1.3  && >= 1.2.1
                      , time             < 1.9  && >= 1.6.0.1
                      , transformers     < 0.6  && >= 0.5.2.0
-  if !os(windows)
+                     , utf8-string      < 1.1  && >= 1.0.1.1
+  if os(windows)
+    build-depends:     Win32            < 2.9  && >= 2.8.3.0
+  else
     build-depends:     unix             < 2.8  && >= 2.7.2.1
   build-depends:       unix-compat      < 0.6  && >= 0.4.3.1
-                     , utf8-string      < 1.1  && >= 1.0.1.1
+
   if flag(dev)
     ghc-options:       -Wall
 
@@ -132,6 +135,7 @@ library c-h-internal
   import:             build-deps, extensions
   exposed-modules:
                        CabalHelper.Compiletime.Cabal
+                       CabalHelper.Compiletime.CompPrograms
                        CabalHelper.Compiletime.Compat.Environment
                        CabalHelper.Compiletime.Compat.Version
                        CabalHelper.Compiletime.Compat.Parsec
@@ -153,6 +157,12 @@ library c-h-internal
                        Paths_cabal_helper
   autogen-modules:
                        Paths_cabal_helper
+  exposed-modules:
+                       Symlink
+  if os(windows)
+    hs-source-dirs:    os/win
+  else
+    hs-source-dirs:    os/posix
   hs-source-dirs:      src
 
 library
@@ -174,7 +184,14 @@ test-suite compile-test
   ghc-options:         -Wall
   build-depends:       c-h-internal
 
-
+test-suite programs-test
+  import:              build-deps, extensions
+  type:                exitcode-stdio-1.0
+  main-is:             ProgramsTest.hs
+  hs-source-dirs:      tests
+  ghc-options:         -Wall
+  build-depends:       c-h-internal
+                     , pretty-show
 
 test-suite ghc-session
   import:              build-deps, extensions
diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs
index 8a3781c..806bf54 100644
--- a/lib/Distribution/Helper.hs
+++ b/lib/Distribution/Helper.hs
@@ -147,6 +147,7 @@ import qualified CabalHelper.Compiletime.Program.Stack as Stack
 import qualified CabalHelper.Compiletime.Program.GHC as GHC
 import qualified CabalHelper.Compiletime.Program.CabalInstall as CabalInstall
 import CabalHelper.Compiletime.Cabal
+import CabalHelper.Compiletime.CompPrograms
 import CabalHelper.Compiletime.Log
 import CabalHelper.Compiletime.Process
 import CabalHelper.Compiletime.Sandbox
@@ -160,14 +161,6 @@ import CabalHelper.Compiletime.Compat.Version
 
 import Distribution.System (buildPlatform)
 import Distribution.Text (display)
-import Distribution.Verbosity (Verbosity, silent, normal, verbose, deafening)
-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
 
 -- $type-conventions
 -- Throughout the API we use the following conventions for type variables:
@@ -754,55 +747,12 @@ getConfProgs qe = do
 -- | Fixup program paths as appropriate for current project-type and bring
 -- 'Programs' into scope as an implicit parameter.
 configurePrograms :: QueryEnvI c pt -> PreInfo pt -> IO Programs
-configurePrograms QueryEnv{..} pre_info = withVerbosity $ do
-  guessCompProgramPaths $ case pre_info of
-    PreInfoStack projPaths ->
-      Stack.patchCompPrograms projPaths qePrograms
-    _ -> qePrograms
-  where
-    -- | Determine ghc-pkg path from ghc path
-    guessCompProgramPaths :: Verbose => Programs -> IO Programs
-    guessCompProgramPaths progs
-      | same ghcProgram progs dprogs = return progs
-    guessCompProgramPaths progs = do
-        let v = getCabalVerbosity
-            mGhcPath0    | same ghcProgram progs dprogs = Nothing
-                         | otherwise = Just $ ghcProgram progs
-            mGhcPkgPath0 | same ghcPkgProgram progs dprogs = Nothing
-                         | otherwise = Just $ ghcPkgProgram progs
-        (_compiler, _mplatform, progdb)
-            <- GHC.configure
-                  v
-                  mGhcPath0
-                  mGhcPkgPath0
-                  ProgDb.defaultProgramDb
-        let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb
-            mghcPath1    = getProg ProgDb.ghcProgram
-            mghcPkgPath1 = getProg ProgDb.ghcPkgProgram
-            ghc = fromMaybe (ghcProgram progs) mghcPath1
-            ghc_pkg = fromMaybe (ghcPkgProgram progs) mghcPkgPath1
-        return progs
-          { ghcProgram    = ghc
-          , ghcPkgProgram = ghc_pkg
-          , stackEnv      = stackEnv progs ++
-            -- TODO: this is a cludge, need to make a symlink farm for
-            -- stack instead. Note: Haddock also has to be in the compiler
-            -- dir.
-            [("PATH", EnvPrepend $ takeDirectory ghc ++ [searchPathSeparator])]
-          , cabalUnitArgs = cabalUnitArgs progs ++
-              maybeToList (("--with-ghc="++) <$> mghcPath1) ++
-              maybeToList (("--with-ghc-pkg="++) <$> mghcPkgPath1)
-          }
-
-    same f o o'  = f o == f o'
-    dprogs = defaultPrograms
-
-getCabalVerbosity :: Verbose => Verbosity
-getCabalVerbosity
-  | ?verbose 2 = normal
-  | ?verbose 3 = verbose
-  | ?verbose 4 = deafening
-  | otherwise = silent
+configurePrograms qe@QueryEnv{..} pre_info = withVerbosity $ do
+  patchBuildToolProgs (projTypeOfQueryEnv qe) <=< guessCompProgramPaths $
+    case pre_info of
+      PreInfoStack projPaths ->
+        Stack.patchCompPrograms projPaths qePrograms
+      _ -> qePrograms
 
 newtype Helper pt
   = Helper { runHelper :: Unit pt -> [String] -> IO [Maybe ChResponse] }
diff --git a/os/posix/Symlink.hs b/os/posix/Symlink.hs
new file mode 100644
index 0000000..6d97072
--- /dev/null
+++ b/os/posix/Symlink.hs
@@ -0,0 +1,2 @@
+module Symlink (createSymbolicLink) where
+import System.Posix.Files (createSymbolicLink)
diff --git a/os/win/Symlink.hs b/os/win/Symlink.hs
new file mode 100644
index 0000000..335f1c4
--- /dev/null
+++ b/os/win/Symlink.hs
@@ -0,0 +1,3 @@
+module Symlink (createSymbolicLink) where
+import System.Win32.SymbolicLink (createSymbolicLinkFile)
+createSymbolicLink = createSymbolicLinkFile
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
diff --git a/tests/ProgramsTest.hs b/tests/ProgramsTest.hs
new file mode 100644
index 0000000..467c1cc
--- /dev/null
+++ b/tests/ProgramsTest.hs
@@ -0,0 +1,76 @@
+{-| This test checks if 'guessCompProgramPaths'\'s behaviour makes sense
+-}
+
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+
+import Control.Monad
+import Data.List
+import System.Directory
+import System.Environment
+import System.Exit
+import System.FilePath
+import System.IO.Temp
+import Text.Show.Pretty
+
+import CabalHelper.Compiletime.Types
+import CabalHelper.Compiletime.CompPrograms
+import Symlink (createSymbolicLink)
+
+main :: IO ()
+main = do
+  prog_name <- getProgName
+  args <- getArgs
+  case prog_name of
+    "programs-test"
+      | "ghc":ver:rest     <- args  -> ghc ver rest
+      | "ghc-pkg":ver:rest <- args  -> ghc_pkg ver rest
+      | "haddock":ver:rest <- args  -> haddock ver rest
+      | otherwise -> do_test
+    _
+      | Just ver <- stripPrefix "ghc-pkg-" prog_name  -> ghc_pkg ver args
+      | Just ver <- stripPrefix "ghc-" prog_name      -> ghc ver args
+      | Just ver <- stripPrefix "haddock-" prog_name  -> haddock ver args
+  where
+    ghc _ver ["--info"] = putStrLn "[]" -- seems we can get away with that :)
+    ghc  ver ["--numeric-version"] = putStrLn ver
+    ghc _ver ["--supported-languages"] = return ()
+
+    ghc_pkg ver ["--version"] =
+      putStrLn $ "GHC package manager version " ++ ver
+
+    haddock _ver ["--version"] =
+      putStrLn $ -- cabal isn't very picky about haddock versions so we just
+                 -- hardocde it here
+        "Haddock version 2.20.0, (c) Simon Marlow 2006" ++
+        "Ported to use the GHC API by David Waern 2006-2008"
+
+do_test :: IO ()
+do_test = do
+  prog <- canonicalizePath =<< getExecutablePath
+
+  withSystemTempDirectory "c-h-programs-test" $ \tmpdir -> do
+
+  forM_ ["8.6.5", "8.4.4"] $ \ver -> do
+
+  let ghc = tmpdir </> "ghc-" ++ ver
+  let ghc_pkg = tmpdir </> "ghc-pkg-" ++ ver
+  let haddock = tmpdir </> "haddock-" ++ ver
+  let progs = defaultPrograms { ghcProgram = ghc }
+
+  createSymbolicLink prog ghc
+  createSymbolicLink prog ghc_pkg
+  createSymbolicLink prog haddock
+
+  let ?verbose = (==4)
+
+  progs' <- guessCompProgramPaths progs
+
+  pPrint (ghc, ghc_pkg, haddock) -- expected
+  pPrint progs' -- actual
+
+  when (not $ and [ ghcPkgProgram progs'  == ghc_pkg
+                  , haddockProgram progs' == haddock
+                  ])
+    exitFailure
+
+  putStr "\n\n"