Fix and refactor CH.C.Compile

..compilation outputs were landing in CWD

3 files changed, 206 insertions, 118 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 =
diff --git a/tests/CompileTest.hs b/tests/CompileTest.hs
index 0f5bf34..e65de8d 100644
--- a/tests/CompileTest.hs
+++ b/tests/CompileTest.hs
@@ -1,5 +1,8 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables, GADTs #-}
 
+import System.Environment (getArgs)
+import System.Directory
+import System.FilePath
 import System.Process
 import System.Exit
 import System.IO
@@ -33,14 +36,34 @@ withinRange'CH v r =
   where
     v' = either (const $ parseVer "1000000000") id v
 
+setupHOME :: IO ()
+setupHOME = do
+  tmp <- fromMaybe "/tmp" <$> lookupEnv "TMPDIR"
+  let home = tmp </> "compile-test-home"
+  _ <- rawSystem "rm" ["-r", home]
+  createDirectory    home
+  setEnv "HOME" home
+
 main :: IO ()
 main = do
-  setEnv "HOME" =<< fromMaybe "/tmp" <$> lookupEnv "TMPDIR"
+  args <- getArgs
+
+  let action
+       | null args = testAllCabalVersions
+       | otherwise = testCabalVersions $ map parseVer' args
+
+  setupHOME
+
   _ <- rawSystem "cabal" ["update"]
 
-  let parseVer' "HEAD" = Left HEAD
-      parseVer' v      = Right $ parseVer v
+  action
 
+parseVer' :: String -> Either HEAD Version
+parseVer' "HEAD" = Left HEAD
+parseVer' v      = Right $ parseVer v
+
+testAllCabalVersions :: IO ()
+testAllCabalVersions = do
   let cabal_versions :: [Either HEAD Version]
       cabal_versions = map parseVer'
            -- "1.14.0" -- not supported at runtime
@@ -105,7 +128,11 @@ main = do
       relevant_cabal_versions =
           reverse $ filter (flip withinRange'CH constraint) cabal_versions
 
-  rvs <- forM relevant_cabal_versions $ \ver -> do
+  testCabalVersions relevant_cabal_versions
+
+testCabalVersions :: [Either HEAD Version] -> IO ()
+testCabalVersions versions = do
+  rvs <- forM versions $ \ver -> do
            let sver = either show showVersion ver
            hPutStrLn stderr $ "\n\n\n\n\n\n====== Compiling with Cabal-" ++ sver
            compilePrivatePkgDb ver
@@ -118,9 +145,9 @@ main = do
                          Left rvc ->
                              "failed (exit code "++show rvc++")"
 
-  let drvs = relevant_cabal_versions `zip` rvs
+  let drvs = versions `zip` rvs
 
-  mapM_ printStatus (relevant_cabal_versions `zip` rvs)
+  mapM_ printStatus drvs
   if any isLeft' $ map snd $ filter ((/=Left HEAD) . fst) drvs
      then exitFailure
      else exitSuccess
@@ -143,8 +170,11 @@ compileWithPkg :: Maybe PackageDbDir
                -> CabalVersion
                -> IO (Either ExitCode FilePath)
 compileWithPkg mdb cabalVer =
-    compile "/does-not-exist" defaultOptions { oVerbose = True } $
-      Compile Nothing mdb cabalVer [cabalPkgId cabalVer]
+    compile
+      (CompileWithCabalPackage mdb cabalVer [cabalPkgId cabalVer] CPSGlobal)
+      "/does-not-exist"
+      defaultOptions { oVerbose = True }
+
 
 cabalPkgId :: CabalVersion -> String
 cabalPkgId (CabalHEAD _commitid) = "Cabal"