Merge branch 'issue-380'

2022-07-07 17:04:42 +02:00 · 2022-07-07 17:04:42 +02:00 · 86a8a32032
commit 86a8a32032
parent 1a43fddca9 13e01ab453
7 changed files with 165 additions and 56 deletions
--- a/app/ghcup/GHCup/OptParse/Compile.hs
+++ b/app/ghcup/GHCup/OptParse/Compile.hs
@ -82,7 +82,7 @@ data HLSCompileOptions = HLSCompileOptions
  { targetHLS    :: Either Version GitBranch
  , jobs         :: Maybe Int
  , setCompile   :: Bool
-  , ovewrwiteVer :: Maybe Version
+  , ovewrwiteVer :: Either Bool Version
  , isolateDir   :: Maybe FilePath
  , cabalProject :: Maybe (Either FilePath URI)
  , cabalProjectLocal :: Maybe URI
@ -145,14 +145,16 @@ Examples:

  compileHLSFooter = [s|Discussion:
  Compiles and installs the specified HLS version.
-  The last argument is a list of GHC versions to compile for.
+  The --ghc arguments are necessary to specify which GHC version to build for/against.
  These need to be available in PATH prior to compilation.

 Examples:
-  # compile 1.4.0 for ghc 8.10.5 and 8.10.7
-  ghcup compile hls -v 1.4.0 -j 12 --ghc 8.10.5 --ghc 8.10.7
-  # compile from master for ghc 8.10.7, linking everything dynamically
-  ghcup compile hls -g master -j 12 --ghc 8.10.7 -- --ghc-options='-dynamic'|]
+  # compile 1.7.0.0 for ghc 8.10.5 and 8.10.7, passing '--allow-newer' to cabal
+  ghcup compile hls -v 1.7.0.0 -j 12 --ghc 8.10.5 --ghc 8.10.7 -- --allow-newer
+  # compile from master for ghc 9.2.3 and use 'git describe' to name the binary
+  ghcup compile hls -g master --git-describe-version --ghc 9.2.3
+  # compile a specific commit for ghc 9.2.3 and set a specifc version for the binary name
+  ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|]


 ghcCompileOpts :: Parser GHCCompileOptions
@ -280,7 +282,7 @@ hlsCompileOpts =
          (Right <$> (GitBranch <$> option
          str
          (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help
-            "The git commit/branch/ref to build from"
+            "The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)"
          ) <*>
          optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)"
            <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"])
@ -295,8 +297,9 @@ hlsCompileOpts =
            )
          )
    <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))
-    <*> optional
-          (option
+    <*>
+         (
+          (Right <$> option
            (eitherReader
              (first (const "Not a valid version") . version . T.pack)
            )
@ -305,6 +308,14 @@ hlsCompileOpts =
            <> (completer $ versionCompleter Nothing HLS)
            )
          )
+          <|>
+          (Left <$> (switch
+                      (long "git-describe-version"
+                         <> help "Use the output of 'git describe' (if building from git) as the VERSION component of the installed binary."
+                      )
+                    )
+          )
+          )
    <*> optional
          (option
            (eitherReader isolateParser)
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -340,7 +340,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
    (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver
  alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))
    (GHC, ver)   = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver
-  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Just over }))
+  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over }))
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver
  alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
    (HLS, ver)   = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
--- a/ghcup.cabal
+++ b/ghcup.cabal
@ -164,8 +164,10 @@ library
    cpp-options:   -DIS_WINDOWS
    other-modules:
      GHCup.Prelude.File.Windows
-      GHCup.Prelude.Process.Windows
      GHCup.Prelude.Windows
+    -- GHCup.OptParse.Run uses this
+    exposed-modules:
+      GHCup.Prelude.Process.Windows

    build-depends:
      , bzlib
--- a/lib/GHCup/GHC.hs
+++ b/lib/GHCup/GHC.hs
@ -566,8 +566,11 @@ rmGHCVer ver = do
      lift $ recycleFile f
      when (not (null survivors)) $ throwE $ UninstallFailed dir survivors
    Nothing -> do
+      isDir <- liftIO $ doesDirectoryExist dir
+      isSyml <- liftIO $ handleIO (\_ -> pure False) $ pathIsSymbolicLink dir
+      when (isDir && not isSyml) $ do
        lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir
-      lift $ recyclePathForcibly dir'
+        recyclePathForcibly dir'

  v' <-
    handle
@ -681,28 +684,53 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
                    , "origin"
                    , fromString rep ]

-          let fetch_args =
-                    [ "fetch"
-                    , "--depth"
-                    , "1"
-                    , "--quiet"
-                    , "origin"
-                    , fromString ref ]
+          -- figure out if we can do a shallow clone
+          remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure [])
+              $ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)
+          let shallow_clone
+                | isCommitHash ref                     = True
+                | fromString ref `elem` remoteBranches = True
+                | otherwise                            = False
+          lift $ logDebug $ "Shallow clone: " <> T.pack (show shallow_clone)
+
+          -- fetch
+          let fetch_args
+                | shallow_clone = ["fetch", "--depth", "1", "--quiet", "origin", fromString ref]
+                | otherwise     = ["fetch", "--tags",       "--quiet", "origin"                ]
          lEM $ git fetch_args

-          lEM $ git [ "checkout", "FETCH_HEAD" ]
+          -- initial checkout
+          lEM $ git [ "checkout", fromString ref ]
+
+          -- gather some info
+          git_describe <- if shallow_clone
+                          then pure Nothing
+                          else fmap Just $ liftE $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
+          chash <- liftE $ gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
+
+          -- clone submodules
          lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
+
+          -- apply patches
          liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack)
+
+          -- bootstrap
          lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
          lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
          CapturedProcess {..} <- lift $ makeOut
            ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
-          case _exitCode of
-            ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
+          tver <- case _exitCode of
+            ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
            ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))

          liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
-        lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver
+          lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n  " <>
+                           "GHC version (from Makefile): " <> prettyVer tver <>
+                           (if not shallow_clone then "\n  " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
+                           (if isCommitHash ref then mempty else "\n  " <> "commit hash: " <> chash)
+          liftIO $ threadDelay 5000000 -- give the user a sec to intervene
+
+          pure tver

        pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
    -- the version that's installed may differ from the
--- a/lib/GHCup/HLS.hs
+++ b/lib/GHCup/HLS.hs
@ -327,7 +327,7 @@ compileHLS :: ( MonadMask m
           => Either Version GitBranch
           -> [Version]
           -> Maybe Int
-           -> Maybe Version
+           -> Either Bool Version
           -> InstallDir
           -> Maybe (Either FilePath URI)
           -> Maybe URI
@ -349,7 +349,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
  Dirs { .. } <- lift getDirs


-  (workdir, tver) <- case targetHLS of
+  (workdir, tver, git_describe) <- case targetHLS of
    -- unpack from version tarball
    Left tver -> do
      lift $ logDebug $ "Requested to compile: " <> prettyVer tver
@ -369,13 +369,13 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
                       (liftE . intoSubdir tmpUnpack)
                       (view dlSubdir dlInfo)

-      pure (workdir, tver)
+      pure (workdir, tver, Nothing)

    -- clone from git
    Right GitBranch{..} -> do
      tmpUnpack <- lift mkGhcupTmpDir
      let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
-      tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
+      reThrowAll @_ @'[ProcessError] DownloadFailed $ do
        let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo
        lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
        lEM $ git [ "init" ]
@ -384,18 +384,34 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
                  , "origin"
                  , fromString rep ]

-        let fetch_args =
-                  [ "fetch"
-                  , "--depth"
-                  , "1"
-                  , "--quiet"
-                  , "origin"
-                  , fromString ref ]
+        -- figure out if we can do a shallow clone
+        remoteBranches <- catchE @ProcessError @'[ProcessError] @'[] (\_ -> pure [])
+            $ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)
+        let shallow_clone
+              | gitDescribeRequested                 = False
+              | isCommitHash ref                     = True
+              | fromString ref `elem` remoteBranches = True
+              | otherwise                            = False
+
+        lift $ logDebug $ "Shallow clone: " <> T.pack (show shallow_clone)
+
+        -- fetch
+        let fetch_args
+              | shallow_clone = ["fetch", "--depth", "1", "--quiet", "origin", fromString ref]
+              | otherwise     = ["fetch", "--tags",       "--quiet", "origin"                ]
        lEM $ git fetch_args

-        lEM $ git [ "checkout", "FETCH_HEAD" ]
-        (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal"))
-        pure . (\c -> Version Nothing c [] Nothing)
+        -- checkout
+        lEM $ git [ "checkout", fromString ref ]
+
+        -- gather some info
+        git_describe <- if shallow_clone
+                        then pure Nothing
+                        else fmap Just $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
+        chash <- gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
+        (Just gpd) <- parseGenericPackageDescriptionMaybe
+          <$> liftIO (B.readFile (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal"))
+        let tver = (\c -> Version Nothing c [] Nothing)
                 . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
                 . versionNumbers
                 . pkgVersion
@ -404,13 +420,25 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
                 $ gpd

        liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
-      lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver
+        lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n  " <>
+                                    "HLS version (from cabal file): " <> prettyVer tver <>
+                                    (if not shallow_clone then "\n  " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
+                                    (if isCommitHash ref then mempty else "\n  " <> "commit hash: " <> chash)

-      pure (tmpUnpack, tver)
+        pure (tmpUnpack, tver, git_describe)

  -- the version that's installed may differ from the
  -- compiled version, so the user can overwrite it
-  let installVer = fromMaybe tver ov
+  installVer <- case ov of
+                  Left True -> case git_describe of
+                                 -- git describe
+                                 Just h -> either (fail . displayException) pure . version $ h
+                                 -- git describe, but not building from git, lol
+                                 Nothing -> pure tver
+                  -- default: use detected version
+                  Left False -> pure tver
+                  -- overwrite version with users value
+                  Right v -> pure v

  liftE $ runBuildAction
    workdir
@ -464,7 +492,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
        pure ghcInstallDir

      forM_ artifacts $ \artifact -> do
-        logInfo $ T.pack (show artifact)
+        logDebug $ T.pack (show artifact)
        liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)
          (tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
        liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
@ -479,6 +507,10 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
    )

  pure installVer
+ where
+  gitDescribeRequested = case ov of
+                           Left b -> b
+                           _      -> False


    -----------------
@ -614,6 +646,9 @@ rmHLSVer ver = do
      lift $ recycleFile f
      when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors
    Nothing -> do
+      isDir <- liftIO $ doesDirectoryExist hlsDir
+      isSyml <- liftIO $ handleIO (\_ -> pure False) $ pathIsSymbolicLink hlsDir
+      when (isDir && not isSyml) $ do
        lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir
        recyclePathForcibly hlsDir'

--- a/lib/GHCup/Prelude/Process/Windows.hs
+++ b/lib/GHCup/Prelude/Process/Windows.hs
@ -211,8 +211,8 @@ exec exe args chdir env = do
    let paths = ["PATH", "Path"]
        curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
        newPath = intercalate [searchPathSeparator] curPaths
-    setEnv "PATH" ""
-    setEnv "Path" newPath
+    liftIO $ setEnv "PATH" ""
+    liftIO $ setEnv "Path" newPath
  cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
  exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
  pure $ toProcessError exe args exit_code
@ -230,8 +230,8 @@ execNoMinGW exe args chdir env = do
    let paths = ["PATH", "Path"]
        curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
        newPath = intercalate [searchPathSeparator] curPaths
-    setEnv "PATH" ""
-    setEnv "Path" newPath
+    liftIO $ setEnv "PATH" ""
+    liftIO $ setEnv "Path" newPath
  let cp = (proc exe args) { cwd = chdir, env = env }
  exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
  pure $ toProcessError exe args exit_code
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@ -61,6 +61,7 @@ import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
                                         hiding ( throwM )
 import           Control.Monad.IO.Unlift        ( MonadUnliftIO( withRunInIO ) )
+import           Data.Char                      ( isHexDigit )
 import           Data.Bifunctor                 ( first )
 import           Data.ByteString                ( ByteString )
 import           Data.Either
@ -1275,3 +1276,35 @@ warnAboutHlsCompatibility = do
        T.pack (prettyShow supportedGHC)

    _ -> return ()
+
+
+
+    -----------
+    --[ Git ]--
+    -----------
+
+
+
+isCommitHash :: String -> Bool
+isCommitHash str' = let hex = all isHexDigit str'
+                        len = length str'
+                    in hex && len == 40
+
+
+gitOut :: (MonadReader env m, HasLog env, MonadIO m) => [String] -> FilePath -> Excepts '[ProcessError] m T.Text
+gitOut args dir = do
+  CapturedProcess {..} <- lift $ executeOut "git" args (Just dir)
+  case _exitCode of
+    ExitSuccess   -> pure $ T.pack $ stripNewlineEnd $ T.unpack $ decUTF8Safe' _stdOut
+    ExitFailure c -> do
+      let pe = NonZeroExit c "git" args
+      lift $ logDebug $ T.pack (prettyShow pe)
+      throwE pe
+
+processBranches :: T.Text -> [String]
+processBranches str' = let lines'   = lines (T.unpack str')
+                           words'   = fmap words lines'
+                           refs     = catMaybes $ fmap (`atMay` 1) words'
+                           branches = catMaybes $ fmap (stripPrefix "refs/heads/") $ filter (isPrefixOf "refs/heads/") refs
+                       in branches
+