Add initial new-build (v2-build) support to wrapper

3 files changed, 142 insertions, 52 deletions

diff --git a/src/CabalHelper/Compiletime/Compat/Version.hs b/src/CabalHelper/Compiletime/Compat/Version.hs
index 853aca5..af17bcb 100644
--- a/src/CabalHelper/Compiletime/Compat/Version.hs
+++ b/src/CabalHelper/Compiletime/Compat/Version.hs
@@ -4,6 +4,7 @@ module CabalHelper.Compiletime.Compat.Version
     , toDataVersion
     , fromDataVersion
     , Data.Version.showVersion
+    , makeDataVersion
     ) where
 
 import qualified Data.Version
@@ -23,3 +24,10 @@ fromDataVersion (Data.Version.Version vs _) = Distribution.Version.mkVersion vs
 toDataVersion = id
 fromDataVersion = id
 #endif
+
+makeDataVersion :: [Int] -> Data.Version.Version
+#if MIN_VERSION_base(4,8,0)
+makeDataVersion = Data.Version.makeVersion
+#else
+makeDataVersion xs = Data.Version.Version xs []
+#endif
diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs
index b39e86f..571240d 100644
--- a/src/CabalHelper/Compiletime/Compile.hs
+++ b/src/CabalHelper/Compiletime/Compile.hs
@@ -23,6 +23,7 @@ License     : AGPL-3
 
 module CabalHelper.Compiletime.Compile where
 
+import Cabal.Plan
 import Control.Applicative
 import Control.Arrow
 import Control.Exception as E
@@ -47,6 +48,10 @@ import System.IO.Error
 import System.IO.Temp
 import Prelude
 
+
+import qualified Data.Text as Text
+import qualified Data.Map.Strict as Map
+
 import Distribution.System (buildPlatform)
 import Distribution.Text (display)
 
@@ -81,13 +86,15 @@ data CompPaths = CompPaths
 -- executable.
 data CompilationProductScope = CPSGlobal | CPSProject
 
-compileHelper :: Options -> Version -> FilePath -> FilePath -> IO (Either ExitCode FilePath)
-compileHelper opts hdrCabalVersion projdir distdir = do
+compileHelper :: Options -> Version -> FilePath -> Maybe (PlanJson, FilePath) -> FilePath -> IO (Either ExitCode FilePath)
+compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do
+  ghcVer <- ghcVersion opts
   Just (prepare, comp) <- runMaybeT $ msum $
     case oCabalPkgDb opts of
       Nothing ->
         [ compileCabalSource
-        , compileSandbox
+        , compileNewBuild ghcVer
+        , compileSandbox ghcVer
         , compileGlobal
         , MaybeT $ Just <$> compileWithCabalInPrivatePkgDb
         ]
@@ -104,7 +111,7 @@ compileHelper opts hdrCabalVersion projdir distdir = do
       vLog opts $ "helper already compiled, using exe: "++compExePath
       return (Right compExePath)
     else do
-      vLog opts $ "helper exe does not exist, compiling"++compExePath
+      vLog opts $ "helper exe does not exist, compiling "++compExePath
       prepare >> compile comp cp opts
 
  where
@@ -115,21 +122,38 @@ compileHelper opts hdrCabalVersion projdir distdir = do
    -- | Check if this version is globally available
    compileGlobal :: MaybeT IO (IO (), Compile)
    compileGlobal = do
-       ver <- MaybeT $ find (== hdrCabalVersion) <$> listCabalVersions opts
+       cabal_versions <- listCabalVersions opts
+       ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions
        vLog opts $ logMsg ++ "user/global package-db"
        return $ (return (), compileWithPkg Nothing ver CPSGlobal)
 
    -- | Check if this version is available in the project sandbox
-   compileSandbox :: MaybeT IO (IO (), Compile)
-   compileSandbox = do
-       let ghcVer = ghcVersion opts
-           mdb_path = getSandboxPkgDb projdir (display buildPlatform) =<< ghcVer
+   compileSandbox :: Version -> MaybeT IO (IO (), Compile)
+   compileSandbox ghcVer = do
+       let mdb_path = getSandboxPkgDb projdir (display buildPlatform) ghcVer
        sandbox <- PackageDbDir <$> MaybeT mdb_path
-       ver <- MaybeT $ logIOError opts "compileSandbox" $
-         find (== hdrCabalVersion) <$> listCabalVersions' opts (Just sandbox)
+       cabal_versions <- listCabalVersions' opts (Just sandbox)
+       ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions
        vLog opts $ logMsg ++ "sandbox package-db"
        return $ (return (), compileWithPkg (Just sandbox) ver CPSProject)
 
+   compileNewBuild :: Version -> MaybeT IO (IO (), Compile)
+   compileNewBuild ghcVer = do
+       (PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure mnewstyle
+       let cabal_pkgid =
+               PkgId (PkgName (Text.pack "Cabal"))
+                     (Ver $ versionBranch hdrCabalVersion)
+           mcabal_unit = listToMaybe $
+             Map.elems $ Map.filter (\Unit {..} -> uPId == cabal_pkgid) pjUnits
+       Unit {} <- maybe mzero pure mcabal_unit
+       let inplace_db_path = distdir_newstyle
+             </> "packagedb" </> ("ghc-" ++ showVersion ghcVer)
+           inplace_db = PackageDbDir inplace_db_path
+       cabal_versions <- listCabalVersions' opts (Just inplace_db)
+       ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions
+       vLog opts $ logMsg ++ "v2-build package-db " ++ inplace_db_path
+       return $ (return (), compileWithPkg (Just inplace_db) ver CPSProject)
+
    -- | Compile the requested Cabal version into an isolated package-db if it's
    -- not there already
    compileWithCabalInPrivatePkgDb :: IO (IO (), Compile)
@@ -322,6 +346,13 @@ exeName CabalVersion {cabalVersion} = intercalate "-"
     , "Cabal" ++ showVersion cabalVersion
     ]
 
+readProcess' :: Options -> FilePath -> [String] -> String -> IO String
+readProcess' opts@Options{..} exe args inp = do
+  vLog opts $ intercalate " " $ map formatProcessArg (oGhcPkgProgram:args)
+  outp <- readProcess exe args inp
+  vLog opts $ unlines $ map ("=> "++) $ lines outp
+  return outp
+
 callProcessStderr'
     :: Options -> Maybe FilePath -> FilePath -> [String] -> IO ExitCode
 callProcessStderr' opts mwd exe args = do
@@ -377,7 +408,7 @@ installCabal opts ever = do
   withSystemTempDirectory "cabal-helper-Cabal-source" $ \tmpdir -> do
     (srcdir, cabalVer) <- case ever of
       Left HEAD -> do
-        second CabalHEAD <$> unpackCabalHEAD tmpdir
+        second CabalHEAD <$> unpackCabalHEAD opts tmpdir
       Right ver -> do
         message ver
         let patch = fromMaybe nopCabalPatchDescription $
@@ -578,13 +609,13 @@ unpackCabal opts cabalVer tmpdir variant = do
   callProcessStderr opts (Just tmpdir) (oCabalProgram opts) args
   return $ CabalSourceDir dir
 
-unpackCabalHEAD :: FilePath -> IO (CabalSourceDir, CommitId)
-unpackCabalHEAD tmpdir = do
+unpackCabalHEAD :: Options -> FilePath -> IO (CabalSourceDir, CommitId)
+unpackCabalHEAD opts 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"] ""
+      withDirectory_ dir $ trim <$> readProcess' opts "git" ["rev-parse", "HEAD"] ""
   return (CabalSourceDir $ dir </> "Cabal", CommitId commit)
  where
    withDirectory_ :: FilePath -> IO a -> IO a
@@ -629,40 +660,46 @@ errorInstallCabal cabalVer _distdir = panicIO $ printf "\
  where
    sver = showVersion cabalVer
 
-listCabalVersions :: Options -> IO [Version]
+listCabalVersions :: Options -> MaybeT IO [Version]
 listCabalVersions opts = listCabalVersions' opts Nothing
 
--- TODO: Include sandbox? Probably only relevant for build-type:custom projects.
-listCabalVersions' :: Options -> Maybe PackageDbDir -> IO [Version]
-listCabalVersions' Options {..} mdb = do
-  let mdbopt = ("--package-conf="++) <$> unPackageDbDir <$> mdb
-      opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
-
-  catMaybes . map (fmap snd . parsePkgId . fromString) . words
-          <$> readProcess oGhcPkgProgram opts ""
+listCabalVersions' :: Options -> Maybe PackageDbDir -> MaybeT IO [Version]
+listCabalVersions' opts@Options {..} mdb = do
+  case mdb of
+    Nothing -> mzero
+    Just (PackageDbDir db_path) -> do
+      exists <- liftIO $ doesDirectoryExist db_path
+      case exists of
+        False -> mzero
+        True  -> MaybeT $ logIOError opts "listCabalVersions'" $ Just <$> do
+          let mdbopt = ("--package-conf="++) <$> unPackageDbDir <$> mdb
+              args = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
+
+          catMaybes . map (fmap snd . parsePkgId . fromString) . words
+                   <$> readProcess' opts oGhcPkgProgram args ""
 
 cabalVersionExistsInPkgDb :: Options -> Version -> PackageDbDir -> IO Bool
 cabalVersionExistsInPkgDb opts cabalVer db@(PackageDbDir db_path) = do
   exists <- doesDirectoryExist db_path
   case exists of
     False -> return False
-    True -> do
+    True -> fromMaybe False <$> runMaybeT (do
       vers <- listCabalVersions' opts (Just db)
-      return $ cabalVer `elem` vers
+      return $ cabalVer `elem` vers)
 
 ghcVersion :: Options -> IO Version
-ghcVersion Options {..} = do
-    parseVer . trim <$> readProcess oGhcProgram ["--numeric-version"] ""
+ghcVersion opts@Options {..} = do
+    parseVer . trim <$> readProcess' opts oGhcProgram ["--numeric-version"] ""
 
 ghcPkgVersion :: Options -> IO Version
-ghcPkgVersion Options {..} = do
-    parseVer . trim . dropWhile (not . isDigit) <$> readProcess oGhcPkgProgram ["--version"] ""
+ghcPkgVersion opts@Options {..} = do
+    parseVer . trim . dropWhile (not . isDigit) <$> readProcess' opts oGhcPkgProgram ["--version"] ""
 
 newtype CabalInstallVersion = CabalInstallVersion { cabalInstallVer :: Version }
 cabalInstallVersion :: Options -> IO CabalInstallVersion
-cabalInstallVersion Options {..} = do
+cabalInstallVersion opts@Options {..} = do
     CabalInstallVersion . parseVer . trim
-      <$> readProcess oCabalProgram ["--numeric-version"] ""
+      <$> readProcess' opts oCabalProgram ["--numeric-version"] ""
 
 createPkgDb :: Options -> CabalVersion -> IO PackageDbDir
 createPkgDb opts@Options {..} cabalVer = do
diff --git a/src/CabalHelper/Compiletime/Wrapper.hs b/src/CabalHelper/Compiletime/Wrapper.hs
index ae936f3..cd92219 100644
--- a/src/CabalHelper/Compiletime/Wrapper.hs
+++ b/src/CabalHelper/Compiletime/Wrapper.hs
@@ -13,9 +13,10 @@
 --
 -- 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 #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns, FlexibleContexts, ViewPatterns #-}
 module Main where
 
+import Cabal.Plan
 import Control.Applicative
 import Control.Monad
 import Data.Char
@@ -23,6 +24,7 @@ import Data.List
 import Data.Maybe
 import Data.String
 import Text.Printf
+import Text.Show.Pretty
 import System.Console.GetOpt
 import System.Environment
 import System.Directory
@@ -32,6 +34,9 @@ import System.Exit
 import System.IO
 import Prelude
 
+import qualified Data.Text as Text
+import qualified Data.Map.Strict as Map
+
 import Distribution.System (buildPlatform)
 import Distribution.Text (display)
 import Distribution.Verbosity (silent, deafening)
@@ -61,7 +66,11 @@ usage = do
 \  [--with-cabal=CABAL_PATH]\n\
 \  [--with-cabal-version=VERSION]\n\
 \  [--with-cabal-pkg-db=PKG_DB]\n\
-\  PROJ_DIR DIST_DIR ( print-exe | package-id | [CABAL_HELPER_ARGS...] ) )\n"
+\  v1-style PROJ_DIR DIST_DIR \n\
+\      ( print-exe | package-id | [CABAL_HELPER_ARGS...] )\n\
+\  v2-style PROJ_DIR DIST_NEWSTYLE_DIR DIST_DIR\n\
+\      ( print-exe | package-id | [CABAL_HELPER_ARGS...] )\n\
+\)\n"
 
 globalArgSpec :: [OptDescr (Options -> Options)]
 globalArgSpec =
@@ -147,7 +156,7 @@ main = handlePanic $ do
     "print-appcachedir":[] -> putStrLn =<< appCacheDir
     "print-build-platform":[] -> putStrLn $ display buildPlatform
 
-    projdir:_distdir:"package-id":[] -> do
+    "oldstyle":projdir:_distdir:"package-id":[] -> do
       let v | oVerbose opts = deafening
             | otherwise    = silent
       -- ghc-mod will catch multiple cabal files existing before we get here
@@ -156,27 +165,63 @@ main = handlePanic $ do
       putStrLn $ show $
         [Just $ ChResponseVersion (display (packageName gpd)) (toDataVersion $ packageVersion gpd)]
 
-    projdir:distdir:args' -> do
+    "v2-style":projdir:distdir_newstyle:unitid':args' -> do
+      let unitid = UnitId $ Text.pack unitid'
+      let plan_path = distdir_newstyle </> "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 panic $ 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
+                 panic $ "\
+\UnitId '"++ unitid' ++"' points to non-local unit: " ++ ppShow u
+               Just Unit {uDistDir=Nothing} -> panic $ printf "\
+\plan.json doesn't contain 'dist-dir' for UnitId '"++ unitid' ++"'"
+               Just Unit {uType=UnitTypeLocal, uDistDir=Just distdir} ->
+                 runHelper opts projdir (Just (plan, distdir_newstyle)) distdir pjCabalLibVersion args'
+               _ -> let
+                   units = map (\(UnitId u) -> Text.unpack u)
+                         $ Map.keys
+                         $ Map.filter ((==UnitTypeLocal) . uType)
+                         $ pjUnits plan
+
+                   units_list = unlines $ map ("  "++) units
+                 in
+                   panic $ "\
+\UnitId '"++ unitid' ++"' not found in plan.json, available local units:\n" ++ units_list
+
+    "v1-style":projdir:distdir:args' -> do
       cfgf <- canonicalizePath (distdir </> "setup-config")
       mhdr <- getCabalConfigHeader cfgf
-      case mhdr of
-        Nothing -> panic $ printf "\
+      case (mhdr, oCabalVersion opts) of
+        (Nothing, _) -> panic $ printf "\
 \Could not read Cabal's persistent setup configuration header\n\
 \- Check first line of: %s\n\
 \- Maybe try: $ cabal configure" cfgf
-        Just (hdrCabalVersion, _) -> do
-          case oCabalVersion opts of
-            Just ver | hdrCabalVersion /= ver -> panic $ printf "\
+        (Just (hdrCabalVersion, _), Just ver)
+          | hdrCabalVersion /= ver -> panic $ printf "\
 \Cabal version %s was requested but setup configuration was\n\
 \written by version %s" (showVersion ver) (showVersion hdrCabalVersion)
-            _ -> do
-              eexe <- compileHelper opts hdrCabalVersion projdir distdir
-              case eexe of
-                  Left e -> exitWith e
-                  Right exe ->
-                    case args' of
-                      "print-exe":_ -> putStrLn exe
-                      _ -> do
-                        (_,_,_,h) <- createProcess $ proc exe args
-                        exitWith =<< waitForProcess h
-    _ -> error "invalid command line"
+        (Just (hdrCabalVersion, _), _) ->
+          runHelper opts projdir Nothing distdir hdrCabalVersion args'
+    _ -> do
+      hPutStrLn stderr "Invalid command line!"
+      usage
+      exitWith $ ExitFailure 1
+
+runHelper :: Options -> FilePath -> Maybe (PlanJson, FilePath) -> FilePath -> DataVersion -> [String] -> IO ()
+runHelper opts projdir mnewstyle distdir cabal_ver args' = do
+  eexe <- compileHelper opts cabal_ver projdir mnewstyle distdir
+  case eexe of
+      Left e -> exitWith e
+      Right exe -> do
+        case args' of
+          "print-exe":_ -> putStrLn exe
+          _ -> do
+            (_,_,_,h) <- createProcess $ proc exe $ projdir : distdir : args'
+            exitWith =<< waitForProcess h