Remove wrapper, integrate functionality into the library

The use of a wrapper executable to compile the real helper was a design mistake
originally intended to isolate the calling application from a dependency on the
Cabal library completely. This isolation turned out to be rather tedious and
thus was ignored soon, the wrapper remained though.

Due to the way cabal-install installs components of a package into seperate
install trees when using new-install finding the wrapper exe reliably has become
pretty much impossible without huge effort. Hence we remove it and integrate the
functionality into the library instead.

1 files changed, 169 insertions, 196 deletions

diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs
index 1d93b84..622972a 100644
--- a/lib/Distribution/Helper.hs
+++ b/lib/Distribution/Helper.hs
@@ -14,10 +14,9 @@
 -- You should have received a copy of the GNU General Public License
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
-{-# LANGUAGE CPP, RecordWildCards, FlexibleContexts, ConstraintKinds,
+{-# LANGUAGE RecordWildCards, FlexibleContexts, ConstraintKinds,
   GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor,
-  NamedFieldPuns, OverloadedStrings
- #-}
+  NamedFieldPuns, OverloadedStrings, ViewPatterns #-}
 
 {-|
 Module      : Distribution.Helper
@@ -80,7 +79,7 @@ module Distribution.Helper (
   , NeedsBuildOutput(..)
 
   -- * General information
-  , buildPlatform
+  , Distribution.Helper.buildPlatform
 
   -- * Stuff that cabal-install really should export
   , Distribution.Helper.getSandboxPkgDb
@@ -90,10 +89,6 @@ module Distribution.Helper (
   , reconfigure
   , writeAutogenFiles
 
-  -- * $libexec related error handling
-  , LibexecNotFoundError(..)
-  , libexecNotFoundError
-
   -- * Reexports
   , module Data.Functor.Apply
   ) where
@@ -105,46 +100,40 @@ import Control.Monad.IO.Class
 import Control.Monad.State.Strict
 import Control.Monad.Reader
 import Control.Exception as E
-import Data.Char
 import Data.List
 import Data.Maybe
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
 import Data.Version
-import Data.Typeable
+import qualified Data.Text as Text
 import Data.Function
 import Data.Functor.Apply
-import Distribution.System (buildOS, OS(Windows))
 import System.Environment
 import System.FilePath hiding ((<.>))
-import qualified System.FilePath as FP
 import System.Directory
 import System.Process
-import System.IO.Unsafe
 import Text.Printf
-import GHC.Generics
+import Text.Show.Pretty
 import Prelude
 
-import Paths_cabal_helper (getLibexecDir)
+
+import CabalHelper.Compiletime.Compile
+import CabalHelper.Compiletime.Types
 import CabalHelper.Shared.InterfaceTypes
 import CabalHelper.Shared.Sandbox
 
--- | Paths or names of various programs we need.
-data Programs = Programs {
-      -- | The path to the @cabal@ program.
-      cabalProgram  :: FilePath,
 
-      -- | The path to the @ghc@ program.
-      ghcProgram    :: FilePath,
+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 qualified CabalHelper.Compiletime.Compat.ProgramDb as ProgDb
+    ( defaultProgramDb, programPath, lookupProgram, ghcProgram, ghcPkgProgram)
+import CabalHelper.Compiletime.Compat.Version
+import CabalHelper.Shared.Common
 
-      -- | The path to the @ghc-pkg@ program. If
-      -- not changed it will be derived from the path to 'ghcProgram'.
-      ghcPkgProgram :: FilePath
-    } deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
--- | Default all programs to their unqualified names, i.e. they will be searched
--- for on @PATH@.
-defaultPrograms :: Programs
-defaultPrograms = Programs "cabal" "ghc" "ghc-pkg"
 
 -- | Environment for running a 'Query'. The real constructor is not exposed,
 -- the field accessors are however. See below. Use the 'mkQueryEnv' smart
@@ -353,35 +342,41 @@ reconfigure readProc progs cabalOpts = do
 
 readHelper :: (MonadIO m, MonadQuery m) => [String] -> m [Maybe ChResponse]
 readHelper args = ask >>= \qe -> liftIO $ do
-  out <- either error id <$> invokeHelper qe args
+  out <- invokeHelper qe args
   let res = read out
   liftIO $ evaluate res `E.catch` \se@(SomeException _) -> do
       md <- lookupEnv' "CABAL_HELPER_DEBUG"
       let msg = "readHelper: exception: '" ++ show se ++ "'"
-      error $ msg ++ case md of
+      panicIO $ msg ++ case md of
         Nothing -> ", for more information set the environment variable CABAL_HELPER_DEBUG"
         Just _ -> ", output: '"++ out ++"'"
 
-invokeHelper :: QueryEnv -> [String] -> IO (Either String String)
-invokeHelper QueryEnv {..} args = do
-  let progArgs = [ "--with-ghc="     ++ ghcProgram qePrograms
-                 , "--with-ghc-pkg=" ++ ghcPkgProgram qePrograms
-                 , "--with-cabal="   ++ cabalProgram qePrograms
-                 ]
-  exe  <- findLibexecExe
-  let args' = progArgs ++ "v1-style":qeProjectDir:qeDistDir:args
-  out <- qeReadProcess exe args' ""
-  (Right <$> evaluate out) `E.catch` \(SomeException _) ->
-      return $ Left $ concat
-                 ["invokeHelper", ": ", exe, " "
-                 , intercalate " " (map show args')
-                 , " failed"
-                 ]
-
-getPackageId :: MonadQuery m => m (String, Version)
-getPackageId = ask >>= \QueryEnv {..} -> do
-  [ Just (ChResponseVersion pkgName pkgVer) ] <- readHelper [ "package-id" ]
-  return (pkgName, pkgVer)
+invokeHelper :: QueryEnv -> [String] -> IO String
+invokeHelper QueryEnv {..} args0 = do
+  let opts = defaultCompileOptions
+             { oPrograms = qePrograms
+             , oCabalPkgDb = PackageDbDir <$> qeCabalPkgDb }
+
+  opts' <- overrideVerbosityEnvVar =<< guessProgramPaths opts
+
+  exe <- wrapperV1 opts' qeProjectDir qeDistDir
+
+  let args1 = qeProjectDir : qeDistDir : args0
+
+  out <- qeReadProcess exe args1 ""
+  evaluate out `E.catch` \(SomeException _) ->
+      panicIO $ concat
+        ["invokeHelper", ": ", exe, " "
+        , intercalate " " (map show args1)
+        , " failed!"
+        ]
+
+getPackageId :: (MonadQuery m, MonadIO m) => m (String, Version)
+getPackageId = ask >>= \QueryEnv {..} -> liftIO $ do
+  let v = silent
+  [cfile] <- filter isCabalFile <$> getDirectoryContents qeProjectDir
+  gpd <- readPackageDescription v (qeProjectDir </> cfile)
+  return $ (display (packageName gpd), toDataVersion (packageVersion gpd))
 
 getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo
 getSomeConfigState = ask >>= \QueryEnv {..} -> do
@@ -439,151 +434,129 @@ writeAutogenFiles qe  =
   liftIO $ void $ invokeHelper qe ["write-autogen-files"]
 
 -- | Get the path to the sandbox package-db in a project
-getSandboxPkgDb :: (FilePath -> [String] -> String -> IO String)
-             -> String
-             -- ^ Cabal build platform, i.e. @buildPlatform@
-             -> Version
-             -- ^ GHC version (@cProjectVersion@ is your friend)
-             -> IO (Maybe FilePath)
-getSandboxPkgDb readProc =
-    CabalHelper.Shared.Sandbox.getSandboxPkgDb $ unsafePerformIO $ buildPlatform readProc
-
-buildPlatform :: (FilePath -> [String] -> String -> IO String) -> IO String
-buildPlatform readProc = do
-  exe  <- findLibexecExe
-  CabalHelper.Shared.Sandbox.dropWhileEnd isSpace <$> readProc exe ["print-build-platform"] ""
-
--- | This exception is thrown by all 'runQuery' functions if the internal
--- wrapper executable cannot be found. You may catch this and present the user
--- an appropriate error message however the default is to print
--- 'libexecNotFoundError'.
-data LibexecNotFoundError = LibexecNotFoundError String FilePath
-                          deriving (Typeable)
-instance Exception LibexecNotFoundError
-instance Show LibexecNotFoundError where
-  show (LibexecNotFoundError exe dir) =
-    libexecNotFoundError exe dir "https://github.com/DanielG/cabal-helper/issues"
-
-findLibexecExe :: IO FilePath
-findLibexecExe = do
-    libexecdir <- getLibexecDir
-    let exeName = "cabal-helper-wrapper"
-        exe = libexecdir </> exeName FP.<.> exeExtension'
-
-    exists <- doesFileExist exe
-
-    if exists
-       then return exe
-       else do
-         mdir <- tryFindCabalHelperTreeDistDir
-         dir <- case mdir of
-           Nothing ->
-               throwIO $ LibexecNotFoundError exeName libexecdir
-           Just dir ->
-               return dir
-
-         return $ dir </> "build" </> exeName </> exeName
-
-findPlanJson :: FilePath -> IO (Maybe FilePath)
-findPlanJson base =
-    findFile (map (</> "cache") $ parents base) "plan.json"
-
-parents :: FilePath -> [FilePath]
-parents path = takeWhile (not . (`elem` ["", "."]) . dropDrive) dirs
-  where dirs = iterate takeDirectory path
-
-data DistDir = DistDir { ddType :: DistDirType, unDistDir :: FilePath }
-  deriving (Eq, Ord, Read, Show)
-data DistDirType = NewBuildDist | OldBuildDist
-  deriving (Eq, Ord, Read, Show)
-
-tryFindCabalHelperTreeDistDir :: IO (Maybe FilePath)
-tryFindCabalHelperTreeDistDir = do
-  exe <- canonicalizePath =<< getExecutablePath'
-  mplan <- findPlanJson exe
-  let mdistdir = takeDirectory . takeDirectory <$> mplan
-  cwd <- getCurrentDirectory
-
-  let candidates = sortBy (compare `on` ddType) $ concat
-        [ maybeToList $ DistDir NewBuildDist <$> mdistdir
-        , [ DistDir OldBuildDist $ (!!3) $ iterate takeDirectory exe ]
-        , if takeFileName exe == "ghc" -- we're probably in ghci; try CWD
-            then [ DistDir NewBuildDist $ cwd </> "dist-newstyle"
-                 , DistDir NewBuildDist $ cwd </> "dist"
-                 , DistDir OldBuildDist $ cwd </> "dist"
-                 ]
-            else []
-        ]
-
-  distdirs
-      <-  filterM isDistDir candidates
-      >>= mapM toOldBuildDistDir
-
-  return $ fmap unDistDir $ join $ listToMaybe $ distdirs
-
-isCabalHelperSourceDir :: FilePath -> IO Bool
-isCabalHelperSourceDir dir =
-    doesFileExist $ dir </> "cabal-helper.cabal"
-
-isDistDir :: DistDir -> IO Bool
-isDistDir (DistDir NewBuildDist dir) =
-    doesFileExist (dir </> "cache" </> "plan.json")
-isDistDir (DistDir OldBuildDist dir) =
-    doesFileExist (dir </> "setup-config")
-
-toOldBuildDistDir :: DistDir -> IO (Maybe DistDir)
-toOldBuildDistDir (DistDir NewBuildDist dir) = do
-    PlanJson {pjUnits} <- decodePlanJson $ dir </> "cache" </> "plan.json"
-    let munit = find isCabalHelperUnit $ Map.elems pjUnits
-    return $ DistDir OldBuildDist <$> join ((\Unit { uDistDir = mdistdir } -> mdistdir) <$> munit)
-  where
-    isCabalHelperUnit
-      Unit { uPId = PkgId (PkgName n) _
-           , uType = UnitTypeLocal
-           , uComps
-           } | n == "cabal-helper" &&
-               Map.member (CompNameExe "cabal-helper-wrapper") uComps
-             = True
-    isCabalHelperUnit _ = False
-toOldBuildDistDir x = return $ Just x
-
-
-
-
-libexecNotFoundError :: String   -- ^ Name of the executable we were trying to
-                                 -- find
-                     -> FilePath -- ^ Path to @$libexecdir@
-                     -> String   -- ^ URL the user will be directed towards to
-                                 -- report a bug.
-                     -> String
-libexecNotFoundError exe dir reportBug = printf
- ( "Could not find $libexecdir/%s\n"
- ++"\n"
- ++"If you are a cabal-helper developer you can set the environment variable\n"
- ++"`cabal_helper_libexecdir' to override $libexecdir[1]. The following will\n"
- ++"work in the cabal-helper source tree:\n"
- ++"\n"
- ++"    $ export cabal_helper_libexecdir=$PWD/dist/build/%s\n"
- ++"\n"
- ++"[1]: %s\n"
- ++"\n"
- ++"If you don't know what I'm talking about something went wrong with your\n"
- ++"installation. Please report this problem here:\n"
- ++"\n"
- ++"    %s") exe exe dir reportBug
-
-getExecutablePath' :: IO FilePath
-getExecutablePath' =
-#if MIN_VERSION_base(4,6,0)
-    getExecutablePath
-#else
-    getProgName
-#endif
+getSandboxPkgDb
+    :: String
+    -- ^ Cabal build platform, i.e. @buildPlatform@
+    -> Version
+    -- ^ GHC version (@cProjectVersion@ is your friend)
+    -> FilePath
+    -- ^ Path to the project directory, i.e. a directory containing a
+    -- @cabal.sandbox.config@ file
+    -> IO (Maybe FilePath)
+getSandboxPkgDb buildPlat ghc_ver projdir =
+    CabalHelper.Shared.Sandbox.getSandboxPkgDb buildPlat ghc_ver projdir
+
+buildPlatform :: String
+buildPlatform = display Distribution.System.buildPlatform
 
 lookupEnv' :: String -> IO (Maybe String)
 lookupEnv' k = lookup k <$> getEnvironment
 
-exeExtension' :: FilePath
-exeExtension'
-    | Windows <- buildOS = "exe"
-    | otherwise = ""
+
+guessProgramPaths :: CompileOptions -> IO CompileOptions
+guessProgramPaths opts = do
+    let v | oVerbose opts = deafening
+          | otherwise     = silent
+
+        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
+
+        progs' = progs
+          { ghcProgram    = fromMaybe (ghcProgram progs) mghcPath1
+          , ghcPkgProgram = fromMaybe (ghcProgram progs) mghcPkgPath1
+          }
+    return opts { oPrograms = progs' }
+ where
+   same f o o'  = f o == f o'
+   progs = oPrograms opts
+   dprogs = defaultPrograms
+
+overrideVerbosityEnvVar :: CompileOptions -> IO CompileOptions
+overrideVerbosityEnvVar opts = do
+  x <- lookup  "CABAL_HELPER_DEBUG" <$> getEnvironment
+  return $ case x of
+    Just _  -> opts { oVerbose = True }
+    Nothing -> opts
+
+wrapperV1
+    :: CompileOptions
+    -> FilePath
+    -> FilePath
+    -> IO FilePath
+wrapperV1 opts projdir distdir = do
+  cfgf <- canonicalizePath (distdir </> "setup-config")
+  mhdr <- getCabalConfigHeader cfgf
+  case (mhdr, oCabalVersion opts) of
+    (Nothing, _) -> panicIO $ printf "\
+\Could not read Cabal's persistent setup configuration header\n\
+\- Check first line of: %s\n\
+\- Maybe try: $ cabal configure" cfgf
+    (Just (hdrCabalVersion, _), Just ver)
+      | hdrCabalVersion /= ver -> panicIO $ printf "\
+\Cabal version %s was requested but setup configuration was\n\
+\written by version %s" (showVersion ver) (showVersion hdrCabalVersion)
+    (Just (hdrCabalVersion, _), _) -> do
+      compileHelper' opts hdrCabalVersion projdir Nothing distdir
+
+wrapperV2
+    :: CompileOptions
+    -> FilePath
+    -> FilePath
+    -> UnitId
+    -> IO (FilePath, FilePath)
+wrapperV2 opts projdir distdir unitid@(UnitId (Text.unpack -> unitid')) = do
+  let plan_path = distdir </> "cache" </> "plan.json"
+  plan@PlanJson {pjCabalLibVersion=Ver (makeDataVersion -> pjCabalLibVersion) }
+      <- decodePlanJson plan_path
+  case oCabalVersion opts of
+    Just ver | pjCabalLibVersion /= ver -> let
+        sver = showVersion ver
+        spjVer = showVersion pjCabalLibVersion
+      in panicIO $ printf "\
+\Cabal version %s was requested but plan.json was written by version %s" sver spjVer
+    _ -> case Map.lookup unitid $ pjUnits plan of
+      Just u@Unit {uType} | uType /= UnitTypeLocal -> do
+        panicIO $ "\
+\UnitId '"++ unitid' ++"' points to non-local unit: " ++ ppShow u
+      Just Unit {uDistDir=Nothing} -> panicIO $ printf "\
+\plan.json doesn't contain 'dist-dir' for UnitId '"++ unitid' ++"'"
+      Just Unit {uType=UnitTypeLocal, uDistDir=Just distdirv1} -> do
+        exe <- compileHelper' opts pjCabalLibVersion projdir (Just (plan, distdir)) distdirv1
+        return (exe, distdirv1)
+      _ -> let
+          units = map (\(UnitId u) -> Text.unpack u)
+                $ Map.keys
+                $ Map.filter ((==UnitTypeLocal) . uType)
+                $ pjUnits plan
+          units_list = unlines $ map ("  "++) units
+        in
+          panicIO $ "\
+\UnitId '"++ unitid' ++"' not found in plan.json, available local units:\n" ++ units_list
+
+
+compileHelper'
+    :: CompileOptions
+    -> Version
+    -> FilePath
+    -> Maybe (PlanJson, FilePath)
+    -> FilePath
+    -> IO FilePath
+compileHelper' opts pjCabalLibVersion projdir mnewstyle distdirv1 = do
+  eexe <- compileHelper opts pjCabalLibVersion projdir mnewstyle distdirv1
+  case eexe of
+    Left rv ->
+        panicIO $ "compileHelper': compiling helper failed! (exit code "++ show rv
+    Right exe ->
+        return exe