From a264cb088ef1cfacf4e56d83171e77e9f7b50472 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 6 Jul 2022 22:49:11 +0200 Subject: [PATCH 1/4] Improve 'ghcup compile hls' 1. short hashes now work 2. print the long hash in addition to the detected cabal version of HLS 3. add `--git-describe-version` switch as an alternative to `--overwrite-version` Fix 1. and 2. for GHC as well. --- app/ghcup/GHCup/OptParse/Compile.hs | 29 +++++++---- app/ghcup/Main.hs | 2 +- lib/GHCup/GHC.hs | 49 +++++++++++++----- lib/GHCup/HLS.hs | 80 ++++++++++++++++++++--------- lib/GHCup/Utils.hs | 33 ++++++++++++ 5 files changed, 147 insertions(+), 46 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index ee0708a..42b6317 100644 --- 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) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index ee2cf08..290aadb 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -340,7 +340,7 @@ Report bugs at |] (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 diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index aad8b68..4a1caad 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -681,28 +681,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 + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + 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 diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs index b99cf2f..609b64b 100644 --- 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,33 +384,61 @@ 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) - . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral) - . versionNumbers - . pkgVersion - . package - . packageDescription - $ gpd + -- checkout + lEM $ git [ "checkout", fromString ref ] - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver + -- 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 + . package + . packageDescription + $ gpd - pure (tmpUnpack, tver) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + 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, 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 @@ -479,6 +507,10 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc ) pure installVer + where + gitDescribeRequested = case ov of + Left b -> b + _ -> False ----------------- diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index e46bf69..07817d6 100644 --- 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 + From 544c6184735249e72d46ec97134b47c99e5b4dd0 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 7 Jul 2022 14:03:49 +0200 Subject: [PATCH 2/4] Don't remove legacy dir if it doesn't exist --- lib/GHCup/GHC.hs | 7 +++++-- lib/GHCup/HLS.hs | 9 ++++++--- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index 4a1caad..4fb1408 100644 --- 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 - lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir - lift $ recyclePathForcibly dir' + 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 + recyclePathForcibly dir' v' <- handle diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs index 609b64b..063474f 100644 --- a/lib/GHCup/HLS.hs +++ b/lib/GHCup/HLS.hs @@ -492,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) @@ -646,8 +646,11 @@ rmHLSVer ver = do lift $ recycleFile f when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors Nothing -> do - lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir - recyclePathForcibly hlsDir' + 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' when (Just ver == isHlsSet) $ do -- set latest hls From 873dd77a6fa4f663443ec4bc20ec9b7f635f2855 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 7 Jul 2022 14:10:18 +0200 Subject: [PATCH 3/4] Fix build on windows --- ghcup.cabal | 4 +++- lib/GHCup/Prelude/Process/Windows.hs | 8 ++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/ghcup.cabal b/ghcup.cabal index c2094ea..6c6583f 100644 --- 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 diff --git a/lib/GHCup/Prelude/Process/Windows.hs b/lib/GHCup/Prelude/Process/Windows.hs index ddfbf6a..89ac9a2 100644 --- 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 From 13e01ab4535ffef73122ccc03dd7fcf21a669690 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 7 Jul 2022 14:24:48 +0200 Subject: [PATCH 4/4] Fix hlint warnings --- lib/GHCup/GHC.hs | 4 ++-- lib/GHCup/HLS.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index 4fb1408..1bfe494 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -726,8 +726,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) 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)) + (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 diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs index 063474f..9b99069 100644 --- a/lib/GHCup/HLS.hs +++ b/lib/GHCup/HLS.hs @@ -422,8 +422,8 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) 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)) + (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, git_describe)