Fix and refactor CH.C.Compile

..compilation outputs were landing in CWD

2 files changed, 167 insertions, 109 deletions

diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs
index a96ded8..7af3cf1 100644
--- a/src/CabalHelper/Compiletime/Compile.hs
+++ b/src/CabalHelper/Compiletime/Compile.hs
@@ -12,7 +12,8 @@
 --
 -- You should have received a copy of the GNU Affero General Public License
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
-{-# LANGUAGE RecordWildCards, FlexibleContexts, NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards, FlexibleContexts, NamedFieldPuns, DeriveFunctor,
+GADTs #-}
 
 {-|
 Module      : CabalHelper.Compiletime.Compile
@@ -28,7 +29,6 @@ import Control.Exception as E
 import Control.Monad
 import Control.Monad.Trans.Maybe
 import Control.Monad.IO.Class
-import Data.Traversable
 import Data.Char
 import Data.List
 import Data.Maybe
@@ -55,13 +55,29 @@ import CabalHelper.Compiletime.Types
 import CabalHelper.Shared.Common
 import CabalHelper.Shared.Sandbox (getSandboxPkgDb)
 
-data Compile = Compile {
-      compCabalSourceDir :: Maybe CabalSourceDir,
-      compPackageDb      :: Maybe PackageDbDir,
-      compCabalVersion   :: CabalVersion,
-      compPackageDeps    :: [String]
+data Compile
+    = CompileWithCabalSource
+      { compCabalSourceDir :: CabalSourceDir
+      }
+    | CompileWithCabalPackage
+      { compPackageDb      :: Maybe PackageDbDir
+      , compCabalVersion   :: CabalVersion
+      , compPackageDeps    :: [String]
+      , compProductTarget  :: CompilationProductScope
+      }
+
+data CompPaths = CompPaths
+    { compSrcDir  :: FilePath
+    , compOutDir  :: FilePath
+    , compExePath :: FilePath
     }
 
+-- | The Helper executable we produce as a compilation product can either be
+-- placed in a per-project location, or a per-user/global location in the user's
+-- home directory. This type controls where the compilation process places the
+-- executable.
+data CompilationProductScope = CPSGlobal | CPSProject
+
 compileHelper :: Options -> Version -> FilePath -> FilePath -> IO (Either ExitCode FilePath)
 compileHelper opts hdrCabalVersion projdir distdir = do
   case oCabalPkgDb opts of
@@ -70,12 +86,12 @@ compileHelper opts hdrCabalVersion projdir distdir = do
           , Right <$> MaybeT (cachedExe (CabalVersion hdrCabalVersion))
           , compileSandbox
           , compileGlobal
-          , cachedCabalPkg
+          , compileWithCachedCabalPkg
           , MaybeT (Just <$> compilePrivatePkgDb)
           ]
     mdb ->
       run [ Right <$> MaybeT (cachedExe (CabalVersion hdrCabalVersion))
-          , liftIO $ compileWithPkg mdb hdrCabalVersion
+          , liftIO $ compileWithPkg mdb hdrCabalVersion CPSProject
           ]
 
  where
@@ -90,7 +106,7 @@ compileHelper opts hdrCabalVersion projdir distdir = do
    compileGlobal = do
        ver <- MaybeT $ find (== hdrCabalVersion) <$> listCabalVersions opts
        vLog opts $ logMsg ++ "user/global package-db"
-       liftIO $ compileWithPkg Nothing ver
+       liftIO $ compileWithPkg Nothing ver CPSGlobal
 
    -- | Check if this version is available in the project sandbox
    compileSandbox :: MaybeT IO (Either ExitCode FilePath)
@@ -101,13 +117,13 @@ compileHelper opts hdrCabalVersion projdir distdir = do
        ver <- MaybeT $ logIOError opts "compileSandbox" $
          find (== hdrCabalVersion) <$> listCabalVersions' opts (Just sandbox)
        vLog opts $ logMsg ++ "sandbox package-db"
-       liftIO $ compileWithPkg (Just sandbox) ver
+       liftIO $ compileWithPkg (Just sandbox) ver CPSProject
 
 
    -- | Check if we already compiled this version of cabal into a private
    -- package-db
-   cachedCabalPkg :: MaybeT IO (Either ExitCode FilePath)
-   cachedCabalPkg = do
+   compileWithCachedCabalPkg :: MaybeT IO (Either ExitCode FilePath)
+   compileWithCachedCabalPkg = do
        db_exists <- liftIO $ cabalVersionExistsInPkgDb opts hdrCabalVersion
        case db_exists of
          False -> mzero
@@ -115,7 +131,7 @@ compileHelper opts hdrCabalVersion projdir distdir = do
              db@(PackageDbDir db_path)
                  <- liftIO $ getPrivateCabalPkgDb opts (CabalVersion hdrCabalVersion)
              vLog opts $ logMsg ++ "private package-db in " ++ db_path
-             liftIO $ compileWithPkg (Just db) hdrCabalVersion
+             liftIO $ compileWithPkg (Just db) hdrCabalVersion CPSGlobal
 
    -- | See if we're in a cabal source tree
    compileCabalSource :: MaybeT IO (Either ExitCode FilePath)
@@ -126,113 +142,160 @@ compileHelper opts hdrCabalVersion projdir distdir = do
        case cabalSrc of
          False -> mzero
          True -> liftIO $ do
-           vLog opts $ "directory above distdir looks like cabal source tree (Cabal.cabal exists)"
-           ver <- cabalFileVersion <$> readFile cabalFile
+           vLog opts $ "projdir looks like Cabal source tree (Cabal.cabal exists)"
+           -- ver <- cabalFileVersion <$> readFile cabalFile
            vLog opts $ "compiling helper with local Cabal source tree"
-           compileWithCabalTree ver projdir'
+           compileWithCabalSource projdir'
 
    -- | Compile the requested cabal version into an isolated package-db
    compilePrivatePkgDb :: IO (Either ExitCode FilePath)
    compilePrivatePkgDb = do
        db <- fst <$> installCabal opts (Right hdrCabalVersion) `E.catch`
              \(SomeException _) -> errorInstallCabal hdrCabalVersion distdir
-       compileWithPkg (Just db) hdrCabalVersion
-
-   compileWithCabalTree ver srcDir =
-       compile distdir opts $ Compile {
-                     compCabalSourceDir       = Just srcDir,
-                     compPackageDb            = Nothing,
-                     compCabalVersion         = CabalVersion ver,
-                     compPackageDeps          = []
-                   }
-
-   compileWithPkg mdb ver =
-       compile distdir opts $ Compile {
-                     compCabalSourceDir       = Nothing,
-                     compPackageDb            = mdb,
-                     compCabalVersion         = CabalVersion ver,
-                     compPackageDeps          = [cabalPkgId ver]
-                   }
+       compileWithPkg (Just db) hdrCabalVersion CPSGlobal
+
+   compileWithCabalSource srcDir =
+       compile CompileWithCabalSource
+                   { compCabalSourceDir       = srcDir
+                   } distdir opts
+
+   compileWithPkg mdb ver target =
+       compile CompileWithCabalPackage
+                   { compPackageDb            = mdb
+                   , compCabalVersion         = CabalVersion ver
+                   , compPackageDeps          = [cabalPkgId ver]
+                   , compProductTarget        = target
+                   } distdir opts
 
    cabalPkgId v = "Cabal-" ++ showVersion v
 
-compile :: FilePath -> Options -> Compile -> IO (Either ExitCode FilePath)
-compile distdir opts@Options {..} Compile {..} = do
-    cnCabalSourceDir
-        <- (canonicalizePath . unCabalSourceDir) `traverse` compCabalSourceDir
+compile :: Compile -> FilePath -> Options -> IO (Either ExitCode FilePath)
+compile comp distdir opts@Options {..} = do
     appdir <- appCacheDir
 
-    let (outdir, exedir, exe, mchsrcdir) =
-          case cnCabalSourceDir of
-             Nothing  -> ( exeName compCabalVersion <.> "build"
-                         , appdir
-                         , appdir </> exeName compCabalVersion
-                         , Nothing
-                         )
-             Just _   -> ( distdir </> "cabal-helper"
-                         , distdir
-                         , distdir </> "cabal-helper" </> "cabal-helper"
-                         , Just $ distdir </> "cabal-helper"
-                         )
-
-    createDirectoryIfMissing True outdir
-    createDirectoryIfMissing True exedir
-
-    withHelperSources mchsrcdir $ \compCabalHelperSourceDir -> do
-
-    vLog opts $ "sourcedir: " ++ compCabalHelperSourceDir
-    vLog opts $ "outdir: " ++ outdir
-    vLog opts $ "exe: " ++ exe
-
-    let (mj1:mj2:mi:_) = case compCabalVersion of
-                         CabalHEAD _commitid -> [10000000, 0, 0]
-                         CabalVersion (Version vs _) -> vs
-    let ghc_opts = concat [
-          [ "-outputdir", outdir
-          , "-o", exe
-          , "-optP-DCABAL_HELPER=1"
-          , "-optP-DCH_MIN_VERSION_Cabal(major1,major2,minor)=(\
-                   \   (major1)  < "++show mj1++" \
-                   \|| (major1) == "++show mj1++" && (major2)  < "++show mj2++"\
-                   \|| (major1) == "++show mj1++" && (major2) == "++show mj2++" && (minor) <= "++show mi++")"
-          ],
-          maybeToList $ ("-package-conf="++) <$> unPackageDbDir <$> compPackageDb,
-          map ("-i"++) $ nub $ "":compCabalHelperSourceDir:maybeToList cnCabalSourceDir,
-
-          if isNothing cnCabalSourceDir
-             then [ "-hide-all-packages"
-                  , "-package", "base"
-                  , "-package", "containers"
-                  , "-package", "directory"
-                  , "-package", "filepath"
-                  , "-package", "process"
-                  , "-package", "bytestring"
-                  , "-package", "ghc-prim"
-                  ]
-             else [],
-
-          concatMap (\p -> ["-package", p]) compPackageDeps,
-          [ "--make"
-          ,  compCabalHelperSourceDir</>"CabalHelper"</>"Runtime"</>"Main.hs"
-          ]
-         ]
+    let paths@CompPaths {..} = compPaths appdir distdir comp
+
+    createDirectoryIfMissing True compOutDir
+    createHelperSources compSrcDir
 
-    rv <- callProcessStderr' opts Nothing oGhcProgram ghc_opts
-    return $ case rv of
-               ExitSuccess -> Right exe
-               e@(ExitFailure _) -> Left e
+    vLog opts $ "compSrcDir: " ++ compSrcDir
+    vLog opts $ "compOutDir: " ++ compOutDir
+    vLog opts $ "compExePath: " ++ compExePath
 
+    invokeGhc opts $ compGhcInvocation comp paths
+
+compPaths :: FilePath -> FilePath -> Compile -> CompPaths
+compPaths appdir distdir c =
+    case c of
+      CompileWithCabalPackage {compProductTarget=CPSGlobal,..} -> CompPaths {..}
+        where
+          compSrcDir  = appdir </> exeName compCabalVersion <.> "build"
+          compOutDir  = compSrcDir
+          compExePath = appdir </> exeName compCabalVersion
+
+      CompileWithCabalPackage {compProductTarget=CPSProject,..} -> distdirPaths
+      CompileWithCabalSource {..} -> distdirPaths
+  where
+    distdirPaths = CompPaths {..}
+        where
+          compSrcDir  = distdir </> "cabal-helper"
+          compOutDir  = compSrcDir
+          compExePath = compOutDir </> "cabal-helper"
+
+data GhcInvocation = GhcInvocation
+    { giOutDir          :: FilePath
+    , giOutput          :: FilePath
+    , giCPPOptions      :: [String]
+    , giPackageDBs      :: [PackageDbDir]
+    , giIncludeDirs     :: [FilePath]
+    , giHideAllPackages :: Bool
+    , giPackages        :: [String]
+    , giInputs          :: [String]
+    }
+
+compGhcInvocation :: Compile -> CompPaths -> GhcInvocation
+compGhcInvocation comp CompPaths {..} =
+    case comp of
+      CompileWithCabalSource {..} ->
+        GhcInvocation
+          { giIncludeDirs = [compSrcDir, unCabalSourceDir compCabalSourceDir]
+          , giPackageDBs  = []
+          , giPackages    = []
+          , ..
+          }
+      CompileWithCabalPackage {..} ->
+        GhcInvocation
+          { giIncludeDirs = [compSrcDir]
+          , giPackageDBs = maybeToList compPackageDb
+          , giPackages =
+              [ "base"
+              , "containers"
+              , "directory"
+              , "filepath"
+              , "process"
+              , "bytestring"
+              , "ghc-prim"
+              ] ++ compPackageDeps
+          , ..
+          }
+  where
+    (mj1:mj2:mi:_) =
+        case compCabalVersion comp of
+          CabalHEAD _commit -> [10000000, 0, 0]
+          CabalVersion (Version vs _) -> vs
+
+    giOutDir = compOutDir
+    giOutput = compExePath
+    giCPPOptions =
+      [ "-DCABAL_HELPER=1"
+      , minVersionMacro (mj1,mj2,mi)
+      ]
+    giHideAllPackages = True
+    giInputs = [compSrcDir</>"CabalHelper"</>"Runtime"</>"Main.hs"]
+
+
+minVersionMacro :: (Int, Int, Int) -> String
+minVersionMacro (mj1,mj2,mi) =
+  "-DCH_MIN_VERSION_Cabal(major1,major2,minor)=\
+  \(  (major1)  < "++show mj1++" \
+  \|| (major1) == "++show mj1++" && (major2)  < "++show mj2++" \
+  \|| (major1) == "++show mj1++" && (major2) == "++show mj2++" && (minor) <= "++show mi++
+  ")"
+
+invokeGhc :: Options -> GhcInvocation -> IO (Either ExitCode FilePath)
+invokeGhc opts@Options {..} GhcInvocation {..} = do
+  rv <- callProcessStderr' opts Nothing oGhcProgram $ concat
+    [ [ "-outputdir", giOutDir
+      , "-o", giOutput
+      ]
+    , map ("-optP"++) giCPPOptions
+    , map ("-package-conf="++) $ unPackageDbDir <$> giPackageDBs
+    , map ("-i"++) $ nub $ "" : giIncludeDirs
+    , if giHideAllPackages then ["-hide-all-packages"] else []
+    , concatMap (\p -> ["-package", p]) giPackages
+    , ["--make"]
+    , giInputs
+    ]
+  return $
+    case rv of
+      ExitSuccess -> Right giOutput
+      e@(ExitFailure _) -> Left e
+
+
+-- | Cabal library version we're compiling the helper exe against.
 data CabalVersion
-    = CabalHEAD    { cvCommitId   :: String }
+    = CabalHEAD  { cvCommitId   :: CommitId }
     | CabalVersion { cabalVersion :: Version }
 
+newtype CommitId = CommitId { unCommitId :: String }
+
 exeName :: CabalVersion -> String
 exeName (CabalHEAD commitid) = intercalate "-"
-    [ "cabal-helper" ++ showVersion version -- our ver
-    , "CabalHEAD" ++ commitid
+    [ "cabal-helper" ++ showVersion version
+    , "CabalHEAD" ++ unCommitId commitid
     ]
 exeName CabalVersion {cabalVersion} = intercalate "-"
-    [ "cabal-helper" ++ showVersion version -- our ver
+    [ "cabal-helper" ++ showVersion version
     , "Cabal" ++ showVersion cabalVersion
     ]
 
@@ -486,14 +549,14 @@ unpackCabal opts cabalVer tmpdir variant = do
   callProcessStderr opts (Just tmpdir) (oCabalProgram opts) args
   return $ CabalSourceDir dir
 
-unpackCabalHEAD :: FilePath -> IO (CabalSourceDir, String)
+unpackCabalHEAD :: FilePath -> IO (CabalSourceDir, CommitId)
 unpackCabalHEAD tmpdir = do
   let dir = tmpdir </> "cabal-head.git"
       url = "https://github.com/haskell/cabal.git"
   ExitSuccess <- rawSystem "git" [ "clone", "--depth=1", url, dir]
   commit <-
       withDirectory_ dir $ trim <$> readProcess "git" ["rev-parse", "HEAD"] ""
-  return (CabalSourceDir $ dir </> "Cabal", commit)
+  return (CabalSourceDir $ dir </> "Cabal", CommitId commit)
  where
    withDirectory_ :: FilePath -> IO a -> IO a
    withDirectory_ dir action =
diff --git a/src/CabalHelper/Compiletime/Data.hs b/src/CabalHelper/Compiletime/Data.hs
index ca291e9..4e512db 100644
--- a/src/CabalHelper/Compiletime/Data.hs
+++ b/src/CabalHelper/Compiletime/Data.hs
@@ -49,8 +49,8 @@ withSystemTempDirectoryEnv tpl f = do
            tmpdir <- getCanonicalTemporaryDirectory
            f =<< createTempDirectory tmpdir tpl
 
-withHelperSources :: Maybe FilePath -> (FilePath -> IO a) -> IO a
-withHelperSources mdir action = withDir mdir $ \dir -> do
+createHelperSources :: FilePath -> IO ()
+createHelperSources dir = do
     let chdir = dir </> "CabalHelper"
     liftIO $ do
       createDirectoryIfMissing True $ chdir </> "Runtime"
@@ -70,11 +70,6 @@ withHelperSources mdir action = withDir mdir $ \dir -> do
         BS.writeFile path $ UTF8.fromString src
         setFileTimes path modtime modtime
 
-    action dir
-  where
-    withDir (Just dir) = \f -> f dir
-    withDir Nothing    = withSystemTempDirectoryEnv "cabal-helper-source"
-
 
 sourceFiles :: [(FilePath, String)]
 sourceFiles =