Add Cabal 2.4 support

3 files changed, 38 insertions, 100 deletions

diff --git a/src/CabalHelper/Compiletime/Compat/ProgramDb.hs b/src/CabalHelper/Compiletime/Compat/ProgramDb.hs
new file mode 100644
index 0000000..89dd886
--- /dev/null
+++ b/src/CabalHelper/Compiletime/Compat/ProgramDb.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE CPP #-}
+module CabalHelper.Compiletime.Compat.ProgramDb
+    ( defaultProgramDb
+    , programPath
+    , lookupProgram
+    , ghcProgram
+    , ghcPkgProgram
+    ) where
+
+import Distribution.Simple.Program
+
+#if !MIN_VERSION_Cabal(2,0,0)
+defaultProgramDb = defaultProgramConfiguration
+#endif
diff --git a/src/CabalHelper/Compiletime/GuessGhc.hs b/src/CabalHelper/Compiletime/GuessGhc.hs
deleted file mode 100644
index f4b33d5..0000000
--- a/src/CabalHelper/Compiletime/GuessGhc.hs
+++ /dev/null
@@ -1,92 +0,0 @@
--- Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren,
---                          Bjorn Bringert, Krasimir Angelov,
---                          Malcolm Wallace, Ross Patterson, Ian Lynagh,
---                          Duncan Coutts, Thomas Schilling,
---                          Johan Tibell, Mikhail Glushenkov
--- All rights reserved.
-
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
-
---     * Redistributions of source code must retain the above copyright
---       notice, this list of conditions and the following disclaimer.
-
---     * Redistributions in binary form must reproduce the above
---       copyright notice, this list of conditions and the following
---       disclaimer in the documentation and/or other materials provided
---       with the distribution.
-
---     * Neither the name of Isaac Jones nor the names of other
---       contributors may be used to endorse or promote products derived
---       from this software without specific prior written permission.
-
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
--- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
--- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
--- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
--- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
--- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
--- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
--- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
--- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
--- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
--- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-{-|
-Module      : CabalHelper.Compiletime.GuessGhc
-Description : Logic for finding @ghc-pkg@ based on path to @ghc@
-License     : BSD3
--}
-
-module CabalHelper.Compiletime.GuessGhc (guessToolFromGhcPath) where
-
-import Data.Maybe
-import Data.Char
-import Distribution.Simple.BuildPaths
-import System.Directory
-import System.FilePath
-
-guessToolFromGhcPath :: FilePath -- ^ Tool name
-                     -> FilePath -- ^ GHC exe path
-                     -> IO (Maybe FilePath)
-guessToolFromGhcPath toolname ghcPath
-  = do let
-           path              = ghcPath
-           dir               = takeDirectory path
-           versionSuffix     = takeVersionSuffix (dropExeExtension path)
-           guessNormal       = dir </> toolname <.> exeExtension'
-           guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)
-                               <.> exeExtension'
-           guessVersioned    = dir </> (toolname ++ versionSuffix)
-                               <.> exeExtension'
-           guesses | null versionSuffix = [guessNormal]
-                   | otherwise          = [guessGhcVersioned,
-                                           guessVersioned,
-                                           guessNormal]
-       exists <- mapM doesFileExist guesses
-       return $ listToMaybe [ file | (file, True) <- zip guesses exists ]
-
-  where takeVersionSuffix :: FilePath -> String
-        takeVersionSuffix = takeWhileEndLE isSuffixChar
-
-        isSuffixChar :: Char -> Bool
-        isSuffixChar c = isDigit c || c == '.' || c == '-'
-
-        dropExeExtension :: FilePath -> FilePath
-        dropExeExtension filepath =
-          case splitExtension filepath of
-            (filepath', extension) | extension == exeExtension' -> filepath'
-                                   | otherwise                 -> filepath
-
--- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but
--- is usually faster (as well as being easier to read).
-takeWhileEndLE :: (a -> Bool) -> [a] -> [a]
-takeWhileEndLE p = fst . foldr go ([], False)
-  where
-    go x (rest, done)
-      | not done && p x = (x:rest, False)
-      | otherwise = (rest, True)
-
-exeExtension' :: FilePath
-exeExtension' = Distribution.Simple.BuildPaths.exeExtension
diff --git a/src/CabalHelper/Compiletime/Wrapper.hs b/src/CabalHelper/Compiletime/Wrapper.hs
index bee64ee..3ea3462 100644
--- a/src/CabalHelper/Compiletime/Wrapper.hs
+++ b/src/CabalHelper/Compiletime/Wrapper.hs
@@ -36,11 +36,13 @@ import Distribution.System (buildPlatform)
 import Distribution.Text (display)
 import Distribution.Verbosity (silent, deafening)
 import Distribution.Package (packageName, packageVersion)
+import Distribution.Simple.GHC as GHC (configure)
 
 import Paths_cabal_helper (version)
+import CabalHelper.Compiletime.Compat.ProgramDb
+    ( defaultProgramDb, programPath, lookupProgram, ghcProgram, ghcPkgProgram)
 import CabalHelper.Compiletime.Compat.Version
 import CabalHelper.Compiletime.Compile
-import CabalHelper.Compiletime.GuessGhc
 import CabalHelper.Compiletime.Types
 import CabalHelper.Shared.Common
 import CabalHelper.Shared.InterfaceTypes
@@ -98,13 +100,27 @@ parseCommandArgs opts argv
 
 guessProgramPaths :: Options -> IO Options
 guessProgramPaths opts = do
-    if not (same oGhcProgram opts dopts) && same oGhcPkgProgram opts dopts
-       then do
-         mghcPkg <- guessToolFromGhcPath "ghc-pkg" (oGhcProgram opts)
-         return opts {
-           oGhcPkgProgram = fromMaybe (oGhcPkgProgram opts) mghcPkg
-         }
-       else return opts
+    let v | oVerbose opts = deafening
+          | otherwise     = silent
+
+        mGhcPath0    | same oGhcProgram opts dopts = Nothing
+                     | otherwise = Just $ oGhcProgram opts
+        mGhcPkgPath0 | same oGhcPkgProgram opts dopts = Nothing
+                     | otherwise = Just $ oGhcPkgProgram opts
+
+    (_compiler, _mplatform, progdb)
+        <- GHC.configure
+               v
+               mGhcPath0
+               mGhcPkgPath0
+               defaultProgramDb
+
+    let mghcPath1    = programPath <$> lookupProgram ghcProgram progdb
+        mghcPkgPath1 = programPath <$> lookupProgram ghcPkgProgram progdb
+
+    return $ opts { oGhcProgram    = fromMaybe (oGhcProgram opts) mghcPath1
+                  , oGhcPkgProgram = fromMaybe (oGhcProgram opts) mghcPkgPath1
+                  }
  where
    same f o o'  = f o == f o'
    dopts = defaultOptions