Make Cabal-HEAD lib v2-build cachable

5 files changed, 93 insertions, 37 deletions

diff --git a/cabal-helper.cabal b/cabal-helper.cabal
index 9c8e995..ff393d6 100644
--- a/cabal-helper.cabal
+++ b/cabal-helper.cabal
@@ -115,6 +115,7 @@ common build-deps
                      , text             < 1.3  && >= 1.0.0.0
                      , template-haskell < 2.15 && >= 2.7.0.0
                      , temporary        < 1.3  && >= 1.2.1
+                     , time             < 1.9  && >= 1.5.0.1
                      , transformers     < 0.6  && >= 0.3.0.0
   if !os(windows)
     build-depends:     unix             < 2.8  && >= 2.5.1.1
diff --git a/src/CabalHelper/Compiletime/Cabal.hs b/src/CabalHelper/Compiletime/Cabal.hs
index 6477b85..d1c6c1d 100644
--- a/src/CabalHelper/Compiletime/Cabal.hs
+++ b/src/CabalHelper/Compiletime/Cabal.hs
@@ -20,23 +20,27 @@ Description : Cabal library source unpacking
 License     : GPL-3
 -}
 
-{-# LANGUAGE DeriveFunctor, CPP #-}
+{-# LANGUAGE DeriveFunctor, ViewPatterns, CPP #-}
 
 module CabalHelper.Compiletime.Cabal where
 
-import Control.Exception (bracket)
-import Control.Monad.IO.Class
 import Data.Char
 import Data.List
 import Data.Maybe
+import Data.Time.Calendar
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
 import Data.Version
-import System.Exit
 import System.Directory
+import System.Exit
 import System.FilePath
+import Text.Printf
+
+
 
 import CabalHelper.Compiletime.Types
 import CabalHelper.Compiletime.Process
-import CabalHelper.Shared.Common (trim, replace, parseVer)
+import CabalHelper.Shared.Common (replace, parseVer, parseVerMay)
 
 type UnpackedCabalVersion = CabalVersion' (CommitId, CabalSourceDir)
 type ResolvedCabalVersion = CabalVersion' CommitId
@@ -182,17 +186,50 @@ unpackCabalHEAD :: Env => FilePath -> IO (CommitId, CabalSourceDir)
 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 (CommitId commit, CabalSourceDir $ dir </> "Cabal")
- where
-   withDirectory_ :: FilePath -> IO a -> IO a
-   withDirectory_ dir action =
-       bracket
-         (liftIO getCurrentDirectory)
-         (liftIO . setCurrentDirectory)
-         (\_ -> liftIO (setCurrentDirectory dir) >> action)
+  callProcessStderr (Just "/") "git" [ "clone", "--depth=1", url, dir]
+  callProcessStderr (Just (dir </> "Cabal")) "cabal"
+    [ "act-as-setup", "--", "sdist"
+    , "--output-directory=" ++ tmpdir </> "Cabal" ]
+  commit <- takeWhile isHexDigit <$>
+    readCreateProcess (proc "git" ["rev-parse", "HEAD"]){ cwd = Just dir } ""
+  ts <-
+    readCreateProcess (proc "git" [ "show", "-s", "--format=%ct", "HEAD" ])
+      { cwd = Just dir } ""
+  let ut = posixSecondsToUTCTime $ fromInteger (read ts)
+      (y,m,d) = toGregorian $ utctDay ut
+      sec = round $ utctDayTime ut
+      datecode = read $ show y ++ show m ++ show d ++ printf "%5d\n" sec
+      sec :: Int; datecode :: Int
+  let cabal_file = tmpdir </> "Cabal/Cabal.cabal"
+  cf0 <- readFile cabal_file
+  let Just cf1 = replaceVersionDecl (setVersion datecode) cf0
+  writeFile (cabal_file<.>"tmp") cf1
+  renameFile (cabal_file<.>"tmp") cabal_file
+  return (CommitId commit, CabalSourceDir $ tmpdir </> "Cabal")
+  where
+    -- If the released version of cabal has 4 components but we use only three
+    -- theirs will always be larger than this one here. That's not really
+    -- critical though.
+    setVersion i (versionBranch -> mj:mi:_:_:[])
+        | odd mi = Just $ makeVersion $ mj:mi:[i]
+    setVersion _ _ = error "unpackCabalHEAD.setVersion: Wrong version format"
+
+-- | Replace the version declaration in a cabal file
+replaceVersionDecl :: (Version -> Maybe Version) -> String -> Maybe String
+replaceVersionDecl ver_fn cf = let
+  Just (before_ver,m) = find (\(_i,t) -> "version:" `isPrefixOf` t) $ splits cf
+  Just (ver_decl,after_ver)
+    = find (\s -> case s of (_i,'\n':x:_) -> not $ isSpace x; _ -> False)
+    $ filter (\(_i,t) -> "\n" `isPrefixOf` t)
+    $ splits m
+  Just vers0 = dropWhile isSpace <$> stripPrefix "version:" ver_decl
+  (vers1,rest) = span (\c -> isDigit c || c == '.') vers0
+  Just verp | all isSpace rest = parseVerMay $ vers1 in do
+  new_ver <- ver_fn verp
+  return $ concat
+    [ before_ver, "version: ", showVersion new_ver, after_ver ]
+  where
+    splits xs = inits xs `zip` tails xs
 
 resolveCabalVersion :: Verbose => CabalVersion -> IO ResolvedCabalVersion
 resolveCabalVersion (CabalVersion ver) = return $ CabalVersion ver
diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs
index f379081..bff9b7e 100644
--- a/src/CabalHelper/Compiletime/Compile.hs
+++ b/src/CabalHelper/Compiletime/Compile.hs
@@ -118,8 +118,10 @@ compileHelper' CompHelperEnv {..} = do
   t0 <- Clock.getTime Clock.Monotonic
   ghcVer <- ghcVersion
   Just (prepare, comp) <- case cheCabalVer of
-    cabalVer@CabalHEAD {} -> do
-      Just <$> compileWithCabalInPrivatePkgDb' ghcVer cabalVer
+    cabalVer@CabalHEAD {} -> runMaybeT $ msum  $ map (\f -> f ghcVer cabalVer)
+      [ compileWithCabalV2GhcEnv'
+      , compileWithCabalInPrivatePkgDb'
+      ]
     CabalVersion cabalVerPlain -> do
       runMaybeT $ msum $ map (\f -> f ghcVer cabalVerPlain) $
         case chePkgDb of
@@ -208,21 +210,31 @@ compileHelper' CompHelperEnv {..} = do
        vLog $ logMsg ++ "v2-build package-db " ++ inplace_db_path
        return $ (return (), compileWithPkg (GPSPackageDBs [inplace_db]) cabalVer CPSProject)
 
+   compileWithCabalV2GhcEnv :: Env => GhcVersion -> Version -> MaybeT IO (IO (), Compile)
+   compileWithCabalV2GhcEnv ghcVer cabalVer =
+     compileWithCabalV2GhcEnv' ghcVer (CabalVersion cabalVer)
+
    -- | If this is a v2-build project it makes sense to use @v2-install@ for
    -- installing Cabal as this will use the @~/.cabal/store@. We use
    -- @--package-env@ to instruct cabal to not meddle with the user's package
    -- environment.
-   compileWithCabalV2GhcEnv :: Env => GhcVersion -> Version -> MaybeT IO (IO (), Compile)
-   compileWithCabalV2GhcEnv ghcVer cabalVer = do
+   compileWithCabalV2GhcEnv' :: Env => GhcVersion -> UnpackedCabalVersion -> MaybeT IO (IO (), Compile)
+   compileWithCabalV2GhcEnv' ghcVer cabalVer = do
        _ <- maybe mzero pure cheDistV2 -- bail if this isn't a v2-build project
        CabalInstallVersion instVer <- liftIO cabalInstallVersion
        guard $ instVer >= (Version [2,4,1,0] [])
        --  ^ didn't test with older versions
        guard $ ghcVer  >= (GhcVersion (Version [8,0] []))
-       env@(PackageEnvFile env_file)
-           <- liftIO $ getPrivateCabalPkgEnv ghcVer cabalVer
+       env@(PackageEnvFile env_file) <- liftIO $
+         getPrivateCabalPkgEnv ghcVer $ unpackedToResolvedCabalVersion cabalVer
        vLog $ logMsg ++ "v2-build package-env " ++ env_file
-       return $ (prepare env, compileWithPkg (GPSPackageEnv env) cabalVer CPSGlobal)
+       return $ (,)
+         (prepare env)
+         CompileWithCabalPackage
+           { compPackageSource = GPSPackageEnv env
+           , compCabalVersion  = unpackedToResolvedCabalVersion cabalVer
+           , compProductTarget = CPSGlobal
+           }
      where
        prepare env = do
          -- exists_in_env <- liftIO $ cabalVersionExistsInPkgDb cheCabalVer db
@@ -237,15 +249,15 @@ compileHelper' CompHelperEnv {..} = do
    compileWithCabalInPrivatePkgDb
        :: (Env, MonadIO m) => GhcVersion -> Version -> m (IO (), Compile)
    compileWithCabalInPrivatePkgDb ghcVer cabalVer =
-       liftIO $ compileWithCabalInPrivatePkgDb' ghcVer (CabalVersion cabalVer)
+       compileWithCabalInPrivatePkgDb' ghcVer (CabalVersion cabalVer)
 
    -- | Compile the requested Cabal version into an isolated package-db if it's
    -- not there already
    compileWithCabalInPrivatePkgDb'
-       :: Env => GhcVersion -> UnpackedCabalVersion -> IO (IO (), Compile)
+       :: (Env, MonadIO m) => GhcVersion -> UnpackedCabalVersion -> m (IO (), Compile)
    compileWithCabalInPrivatePkgDb' ghcVer cabalVer = do
-       db@(PackageDbDir db_path)
-           <- getPrivateCabalPkgDb $ unpackedToResolvedCabalVersion cabalVer
+       db@(PackageDbDir db_path) <- liftIO $
+         getPrivateCabalPkgDb $ unpackedToResolvedCabalVersion cabalVer
        vLog $ logMsg ++ "private package-db in " ++ db_path
        return $ (,)
          (prepare db)
diff --git a/src/CabalHelper/Compiletime/Program/CabalInstall.hs b/src/CabalHelper/Compiletime/Program/CabalInstall.hs
index f989a02..f6c0018 100644
--- a/src/CabalHelper/Compiletime/Program/CabalInstall.hs
+++ b/src/CabalHelper/Compiletime/Program/CabalInstall.hs
@@ -138,7 +138,7 @@ runSetupHs
     -> UnpackedCabalVersion
     -> CabalInstallVersion
     -> IO ()
-runSetupHs ghcVer db srcdir iCabalVer CabalInstallVersion {..}
+runSetupHs ghcVer db srcdir cabalVer CabalInstallVersion {..}
     | cabalInstallVer >= parseVer "1.24" = do
       go $ \args -> callProcessStderr (Just srcdir) (cabalProgram ?progs) $
         [ "act-as-setup", "--" ] ++ args
@@ -148,9 +148,9 @@ runSetupHs ghcVer db srcdir iCabalVer CabalInstallVersion {..}
   where
     parmake_opt :: Maybe Int -> [String]
     parmake_opt nproc'
-        | CabalHEAD _ <- iCabalVer =
+        | CabalHEAD _ <- cabalVer =
             ["-j"++nproc]
-        | CabalVersion ver <- iCabalVer,  ver >= Version [1,20] [] =
+        | CabalVersion ver <- cabalVer, ver >= Version [1,20] [] =
             ["-j"++nproc]
         | otherwise =
             []
@@ -195,13 +195,19 @@ cabalWithGHCProgOpts = concat
       else []
   ]
 
+-- TODO: This needs the big message blub from above
 installCabalLibV2 :: Env => GhcVersion -> UnpackedCabalVersion -> PackageEnvFile -> IO ()
-installCabalLibV2 _ (CabalHEAD _) _ = error "TODO: `installCabalLibV2 _ CabalHEAD _` is unimplemented"
-installCabalLibV2 _ghcVer (CabalVersion cabalVer) (PackageEnvFile env_file) = do
+installCabalLibV2 _ghcVer cv (PackageEnvFile env_file) = do
   exists <- doesFileExist env_file
   if exists
     then return ()
     else do
+    (target, cwd) <- case cv of
+      CabalVersion cabalVer -> do
+        tmp <- getTemporaryDirectory
+        return $ ("Cabal-"++showVersion cabalVer, tmp)
+      CabalHEAD (_commitid, CabalSourceDir srcdir) -> do
+        return (".", srcdir)
     CabalInstallVersion {..} <- cabalInstallVersion
     cabal_opts <- return $ concat
         [ if cabalInstallVer >= Version [1,20] []
@@ -214,16 +220,16 @@ installCabalLibV2 _ghcVer (CabalVersion cabalVer) (PackageEnvFile env_file) = do
         , cabalV2WithGHCProgOpts
         , [ "--package-env=" ++ env_file
           , "--lib"
-          , "Cabal-"++showVersion cabalVer
+          , target
           ]
         , if | ?verbose 3 -> ["-v2"]
              | ?verbose 4 -> ["-v3"]
              | otherwise -> []
         ]
-    tmp <- getTemporaryDirectory
-    callProcessStderr (Just tmp) (cabalProgram ?progs) cabal_opts
+    callProcessStderr (Just cwd) (cabalProgram ?progs) cabal_opts
     hPutStrLn stderr "done"
 
+
 cabalV2WithGHCProgOpts :: Progs => [String]
 cabalV2WithGHCProgOpts = concat
   [ [ "--with-compiler=" ++ ghcProgram ?cprogs ]
diff --git a/src/CabalHelper/Compiletime/Program/GHC.hs b/src/CabalHelper/Compiletime/Program/GHC.hs
index b58eab0..97b04ed 100644
--- a/src/CabalHelper/Compiletime/Program/GHC.hs
+++ b/src/CabalHelper/Compiletime/Program/GHC.hs
@@ -94,12 +94,12 @@ getPrivateCabalPkgDb cabalVer = do
   return $ PackageDbDir db_path
 
 getPrivateCabalPkgEnv
-    :: Verbose => GhcVersion -> Version -> IO PackageEnvFile
+    :: Verbose => GhcVersion -> ResolvedCabalVersion -> IO PackageEnvFile
 getPrivateCabalPkgEnv ghcVer cabalVer = do
   appdir <- appCacheDir
   let env_path =
         appdir </> "ghc-" ++ showGhcVersion ghcVer ++ ".package-envs"
-               </> "Cabal-" ++ showVersion cabalVer ++ ".package-env"
+               </> "Cabal-" ++ showResolvedCabalVersion cabalVer ++ ".package-env"
   return $ PackageEnvFile env_path
 
 listCabalVersions