Compare commits

...

16 Commits

Author SHA1 Message Date
13e01ab453 Fix hlint warnings 2022-07-07 15:05:51 +02:00
873dd77a6f Fix build on windows 2022-07-07 15:05:51 +02:00
544c618473 Don't remove legacy dir if it doesn't exist 2022-07-07 14:03:49 +02:00
a264cb088e 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.
2022-07-06 22:49:11 +02:00
1a43fddca9 Improve about docs 2022-07-02 20:34:19 +02:00
bdfb1a3a9b Merge remote-tracking branch 'origin/merge-requests/264' 2022-06-26 23:14:36 +02:00
9b8b3e8126 Merge remote-tracking branch 'origin/merge-requests/263' 2022-06-26 23:14:10 +02:00
d657c17df4 Merge branch 'issue-375' 2022-06-26 23:11:32 +02:00
why-not-try-calmer
e143c06697 VSCode integration
Typo
2022-06-16 11:07:12 +02:00
Jens Petersen
29da21f5dc bootstrap-haskell: s/will download/can download/
A one word tweak to weaken the language in the initial explanation
to make it "less scary": in general ghcup does not always download
all of ghcup, ghc, cabal, stack, and hls
(unless requested or they are not already installed, etc),
but "will download" sounds like the user is has no choice here
except to always download everything,
which might give them second thoughts about trying this script
and hence adopting ghcup.

Perhaps the wording could be made further more precise,
but at least "can" gives one less anxiety.
2022-06-11 13:06:54 +08:00
d1c72cdff4 Add --mingw-path switch to 'ghcup run' 2022-06-06 23:03:45 +02:00
565bb59f45 Fix ghcup_bootstrap test 2022-06-06 23:03:07 +02:00
aae3f31c50 Fix bootstrap-haskell picking system cabal 2022-06-06 23:03:07 +02:00
0ce9b5d352 Fix test 2022-06-06 23:03:07 +02:00
bf0e5b37ca Test issue #375 2022-06-06 20:22:45 +02:00
fe620835be Fix 'ghcup run' on windows, fixes #375 2022-06-06 20:18:10 +02:00
13 changed files with 228 additions and 61 deletions

View File

@@ -97,17 +97,23 @@ rm -rf "${GHCUP_DIR}"
eghcup --numeric-version eghcup --numeric-version
eghcup install ghc ${GHC_VERSION} eghcup install ghc ${GHC_VERSION}
eghcup unset ghc ${GHC_VERSION}
ls -lah "$(eghcup whereis -d ghc ${GHC_VERSION})" ls -lah "$(eghcup whereis -d ghc ${GHC_VERSION})"
[ "`$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version`" = "${GHC_VERSION}" ] [ "`$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version`" = "${GHC_VERSION}" ]
[ "`eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version`" = "${GHC_VERSION}" ] [ "`eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version`" = "${GHC_VERSION}" ]
[ "`ghcup run --ghc ${GHC_VERSION} -- ghc -e 'Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)'`" = "`$(ghcup whereis ghc ${GHC_VERSION}) -e 'Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)'`" ]
eghcup set ghc ${GHC_VERSION} eghcup set ghc ${GHC_VERSION}
eghcup install cabal ${CABAL_VERSION} eghcup install cabal ${CABAL_VERSION}
[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ] [ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
eghcup unset cabal eghcup unset cabal
"$GHCUP_BIN"/cabal --version && exit 1 || echo yes "$GHCUP_BIN"/cabal --version && exit 1 || echo yes
eghcup set cabal ${CABAL_VERSION}
[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ] # make sure no cabal is set when running 'ghcup run' to check that PATH propagages properly
# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
[ "`eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ] [ "`eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version`" = "${CABAL_VERSION}" ]
eghcup set cabal ${CABAL_VERSION}
[ "`$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version`" = "${CABAL_VERSION}" ]
if [ "${OS}" != "FREEBSD" ] ; then if [ "${OS}" != "FREEBSD" ] ; then
if [ "${ARCH}" = "64" ] ; then if [ "${ARCH}" = "64" ] ; then

View File

@@ -82,7 +82,7 @@ data HLSCompileOptions = HLSCompileOptions
{ targetHLS :: Either Version GitBranch { targetHLS :: Either Version GitBranch
, jobs :: Maybe Int , jobs :: Maybe Int
, setCompile :: Bool , setCompile :: Bool
, ovewrwiteVer :: Maybe Version , ovewrwiteVer :: Either Bool Version
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
, cabalProject :: Maybe (Either FilePath URI) , cabalProject :: Maybe (Either FilePath URI)
, cabalProjectLocal :: Maybe URI , cabalProjectLocal :: Maybe URI
@@ -145,14 +145,16 @@ Examples:
compileHLSFooter = [s|Discussion: compileHLSFooter = [s|Discussion:
Compiles and installs the specified HLS version. 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. These need to be available in PATH prior to compilation.
Examples: Examples:
# compile 1.4.0 for ghc 8.10.5 and 8.10.7 # compile 1.7.0.0 for ghc 8.10.5 and 8.10.7, passing '--allow-newer' to cabal
ghcup compile hls -v 1.4.0 -j 12 --ghc 8.10.5 --ghc 8.10.7 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 8.10.7, linking everything dynamically # compile from master for ghc 9.2.3 and use 'git describe' to name the binary
ghcup compile hls -g master -j 12 --ghc 8.10.7 -- --ghc-options='-dynamic'|] 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 ghcCompileOpts :: Parser GHCCompileOptions
@@ -280,7 +282,7 @@ hlsCompileOpts =
(Right <$> (GitBranch <$> option (Right <$> (GitBranch <$> option
str str
(short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help (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)" 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"]) <> 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")) <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))
<*> optional <*>
(option (
(Right <$> option
(eitherReader (eitherReader
(first (const "Not a valid version") . version . T.pack) (first (const "Not a valid version") . version . T.pack)
) )
@@ -305,6 +308,14 @@ hlsCompileOpts =
<> (completer $ versionCompleter Nothing HLS) <> (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 <*> optional
(option (option
(eitherReader isolateParser) (eitherReader isolateParser)

View File

@@ -18,6 +18,7 @@ import GHCup.Prelude
import GHCup.Prelude.File import GHCup.Prelude.File
#ifdef IS_WINDOWS #ifdef IS_WINDOWS
import GHCup.Prelude.Process import GHCup.Prelude.Process
import GHCup.Prelude.Process.Windows ( execNoMinGW )
#endif #endif
import GHCup.Prelude.Logger import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ import GHCup.Prelude.String.QQ
@@ -58,6 +59,7 @@ import qualified System.Posix.Process as SPP
data RunOptions = RunOptions data RunOptions = RunOptions
{ runAppendPATH :: Bool { runAppendPATH :: Bool
, runInstTool' :: Bool , runInstTool' :: Bool
, runMinGWPath :: Bool
, runGHCVer :: Maybe ToolVersion , runGHCVer :: Maybe ToolVersion
, runCabalVer :: Maybe ToolVersion , runCabalVer :: Maybe ToolVersion
, runHLSVer :: Maybe ToolVersion , runHLSVer :: Maybe ToolVersion
@@ -82,6 +84,8 @@ runOpts =
(short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)") (short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)")
<*> switch <*> switch
(short 'i' <> long "install" <> help "Install the tool, if missing") (short 'i' <> long "install" <> help "Install the tool, if missing")
<*> switch
(short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)")
<*> optional <*> optional
(option (option
(eitherReader toolVersionEither) (eitherReader toolVersionEither)
@@ -249,7 +253,9 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
pure ExitSuccess pure ExitSuccess
#else #else
r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv) r' <- if runMinGWPath
then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv)
case r' of case r' of
VRight _ -> pure ExitSuccess VRight _ -> pure ExitSuccess
VLeft e -> do VLeft e -> do

View File

@@ -340,7 +340,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver
alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver })) alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))
(GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver (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 (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver })) alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver

View File

@@ -74,12 +74,15 @@ cabal-install/HLS/stack are installed in `~/.ghcup/bin/<tool>-<ver>` and have un
## Known users ## Known users
* Github actions: * CI:
- [actions/virtual-environments](https://github.com/actions/virtual-environments) - [Github actions/virtual-environments](https://github.com/actions/virtual-environments)
- [haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup) - [Github haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
- [haskell-ci](https://github.com/haskell-CI/haskell-ci)
* mirrors: * mirrors:
- [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup) - [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
* tools: * tools:
- [vscode-haskell](https://github.com/haskell/vscode-haskell)
- [nvim-lsp-installer](https://github.com/williamboman/nvim-lsp-installer)
- [vabal](https://github.com/Franciman/vabal) - [vabal](https://github.com/Franciman/vabal)
## Known problems ## Known problems

View File

@@ -200,6 +200,14 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
See [ghcup.vim](https://github.com/hasufell/ghcup.vim). See [ghcup.vim](https://github.com/hasufell/ghcup.vim).
## VSCode integration
The developers of the Haskell Language Server offer an [extension](https://github.com/haskell/vscode-haskell) tightly integrated with the [Haskell Language Server](https://github.com/haskell/haskell-language-server). To get started:
1. Install GHCup. During installation, opt in to install the Haskell Language Server (HLS).
2. Install the extension (from VSCode: Ctrl + P and then `ext install haskell.haskell`).
3. Make sure your project uses the GHC version installed from GHCup (otherwise HLS is likely to fail on launch):
- instructions for [stack](https://docs.haskellstack.org/en/stable/yaml_configuration/#system-ghc)
## Get help ## Get help
* [Libera IRC chat on #haskell-ghcup or #haskell](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup) * [Libera IRC chat on #haskell-ghcup or #haskell](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup)

View File

@@ -164,8 +164,10 @@ library
cpp-options: -DIS_WINDOWS cpp-options: -DIS_WINDOWS
other-modules: other-modules:
GHCup.Prelude.File.Windows GHCup.Prelude.File.Windows
GHCup.Prelude.Process.Windows
GHCup.Prelude.Windows GHCup.Prelude.Windows
-- GHCup.OptParse.Run uses this
exposed-modules:
GHCup.Prelude.Process.Windows
build-depends: build-depends:
, bzlib , bzlib

View File

@@ -566,8 +566,11 @@ rmGHCVer ver = do
lift $ recycleFile f lift $ recycleFile f
when (not (null survivors)) $ throwE $ UninstallFailed dir survivors when (not (null survivors)) $ throwE $ UninstallFailed dir survivors
Nothing -> do Nothing -> do
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir isDir <- liftIO $ doesDirectoryExist dir
lift $ recyclePathForcibly 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' <- v' <-
handle handle
@@ -681,28 +684,53 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
, "origin" , "origin"
, fromString rep ] , fromString rep ]
let fetch_args = -- figure out if we can do a shallow clone
[ "fetch" remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure [])
, "--depth" $ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)
, "1" let shallow_clone
, "--quiet" | isCommitHash ref = True
, "origin" | fromString ref `elem` remoteBranches = True
, fromString ref ] | 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 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" ] lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
-- apply patches
liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack)
-- bootstrap
lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
CapturedProcess {..} <- lift $ makeOut CapturedProcess {..} <- lift $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
case _exitCode of tver <- case _exitCode of
ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut 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)) 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) 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) pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
-- the version that's installed may differ from the -- the version that's installed may differ from the

View File

@@ -327,7 +327,7 @@ compileHLS :: ( MonadMask m
=> Either Version GitBranch => Either Version GitBranch
-> [Version] -> [Version]
-> Maybe Int -> Maybe Int
-> Maybe Version -> Either Bool Version
-> InstallDir -> InstallDir
-> Maybe (Either FilePath URI) -> Maybe (Either FilePath URI)
-> Maybe URI -> Maybe URI
@@ -349,7 +349,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
Dirs { .. } <- lift getDirs Dirs { .. } <- lift getDirs
(workdir, tver) <- case targetHLS of (workdir, tver, git_describe) <- case targetHLS of
-- unpack from version tarball -- unpack from version tarball
Left tver -> do Left tver -> do
lift $ logDebug $ "Requested to compile: " <> prettyVer tver lift $ logDebug $ "Requested to compile: " <> prettyVer tver
@@ -369,13 +369,13 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
(liftE . intoSubdir tmpUnpack) (liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo) (view dlSubdir dlInfo)
pure (workdir, tver) pure (workdir, tver, Nothing)
-- clone from git -- clone from git
Right GitBranch{..} -> do Right GitBranch{..} -> do
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing 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 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)" lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ] lEM $ git [ "init" ]
@@ -384,33 +384,61 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
, "origin" , "origin"
, fromString rep ] , fromString rep ]
let fetch_args = -- figure out if we can do a shallow clone
[ "fetch" remoteBranches <- catchE @ProcessError @'[ProcessError] @'[] (\_ -> pure [])
, "--depth" $ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)
, "1" let shallow_clone
, "--quiet" | gitDescribeRequested = False
, "origin" | isCommitHash ref = True
, fromString ref ] | 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 fetch_args
lEM $ git [ "checkout", "FETCH_HEAD" ] -- checkout
(Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal")) lEM $ git [ "checkout", fromString ref ]
pure . (\c -> Version Nothing c [] Nothing)
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
. versionNumbers
. pkgVersion
. package
. packageDescription
$ gpd
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) -- gather some info
lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver 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 -- the version that's installed may differ from the
-- compiled version, so the user can overwrite it -- 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 liftE $ runBuildAction
workdir workdir
@@ -464,7 +492,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
pure ghcInstallDir pure ghcInstallDir
forM_ artifacts $ \artifact -> do forM_ artifacts $ \artifact -> do
logInfo $ T.pack (show artifact) logDebug $ T.pack (show artifact)
liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt) liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)
(tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt) (tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)
liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt) liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)
@@ -479,6 +507,10 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
) )
pure installVer pure installVer
where
gitDescribeRequested = case ov of
Left b -> b
_ -> False
----------------- -----------------
@@ -614,8 +646,11 @@ rmHLSVer ver = do
lift $ recycleFile f lift $ recycleFile f
when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors
Nothing -> do Nothing -> do
lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir isDir <- liftIO $ doesDirectoryExist hlsDir
recyclePathForcibly 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 when (Just ver == isHlsSet) $ do
-- set latest hls -- set latest hls

View File

@@ -206,10 +206,36 @@ exec :: MonadIO m
-> Maybe [(String, String)] -- ^ optional environment -> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ()) -> m (Either ProcessError ())
exec exe args chdir env = do exec exe args chdir env = do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
forM_ (Map.fromList <$> env) $ \cEnv -> do
let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] curPaths
liftIO $ setEnv "PATH" ""
liftIO $ setEnv "Path" newPath
cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env }) cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
pure $ toProcessError exe args exit_code pure $ toProcessError exe args exit_code
-- | Like 'exec', except doesn't add msys2 stuff to PATH.
execNoMinGW :: MonadIO m
=> FilePath -- ^ thing to execute
-> [FilePath] -- ^ args for the thing
-> Maybe FilePath -- ^ optionally chdir into this
-> Maybe [(String, String)] -- ^ optional environment
-> m (Either ProcessError ())
execNoMinGW exe args chdir env = do
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375
forM_ (Map.fromList <$> env) $ \cEnv -> do
let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] curPaths
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
-- | Thin wrapper around `executeFile`. -- | Thin wrapper around `executeFile`.
execShell :: MonadIO m execShell :: MonadIO m

View File

@@ -61,6 +61,7 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
import Data.Char ( isHexDigit )
import Data.Bifunctor ( first ) import Data.Bifunctor ( first )
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either import Data.Either
@@ -1275,3 +1276,35 @@ warnAboutHlsCompatibility = do
T.pack (prettyShow supportedGHC) T.pack (prettyShow supportedGHC)
_ -> return () _ -> 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

View File

@@ -133,6 +133,15 @@ _eghcup() {
fi fi
} }
ecabal() {
edo _ecabal "$@"
}
_ecabal() {
# shellcheck disable=SC2086
"${GHCUP_BIN}/cabal" "$@"
}
_done() { _done() {
echo echo
echo "===============================================================================" echo "==============================================================================="
@@ -537,7 +546,7 @@ adjust_cabal_config() {
else else
cabal_bin="$HOME/AppData/Roaming/cabal/bin" cabal_bin="$HOME/AppData/Roaming/cabal/bin"
fi fi
edo cabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$cabal_bin"), $(cygpath -w "$GHCUP_MSYS2"/mingw64/bin), $(cygpath -w "$GHCUP_MSYS2"/usr/bin)" -a "extra-include-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/include)" -a "extra-lib-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/lib)" -f init ecabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$cabal_bin"), $(cygpath -w "$GHCUP_MSYS2"/mingw64/bin), $(cygpath -w "$GHCUP_MSYS2"/usr/bin)" -a "extra-include-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/include)" -a "extra-lib-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/lib)" -f init
} }
ask_cabal_config_init() { ask_cabal_config_init() {
@@ -688,7 +697,7 @@ find_shell
echo echo
echo "Welcome to Haskell!" echo "Welcome to Haskell!"
echo echo
echo "This script will download and install the following binaries:" echo "This script can download and install the following binaries:"
echo " * ghcup - The Haskell toolchain installer" echo " * ghcup - The Haskell toolchain installer"
echo " * ghc - The Glasgow Haskell Compiler" echo " * ghc - The Glasgow Haskell Compiler"
echo " * cabal - The Cabal build tool for managing Haskell software" echo " * cabal - The Cabal build tool for managing Haskell software"

View File

@@ -242,7 +242,7 @@ if ($Silent -and !($InstallDir)) {
Print-Msg -color Magenta -msg (@' Print-Msg -color Magenta -msg (@'
Welcome to Haskell! Welcome to Haskell!
This script will download and install the following programs: This script can download and install the following programs:
* ghcup - The Haskell toolchain installer * ghcup - The Haskell toolchain installer
* ghc - The Glasgow Haskell Compiler * ghc - The Glasgow Haskell Compiler
* msys2 - A linux-style toolchain environment required for many operations * msys2 - A linux-style toolchain environment required for many operations