Compare commits

...

15 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
028696d4be Merge branch 'issue-377' 2022-06-09 15:29:01 +02:00
4022edb12e Allow passing bindist configure args wrt #377 2022-06-09 14:42:01 +02:00
fde5044194 Merge branch 'issue-371' 2022-06-07 18:44:31 +02:00
3af1286ab7 Fix ghcup_bootstrap test 2022-06-07 17:49:33 +02:00
bcff46d3d4 Fix mingw PATH handling wrt #371 2022-06-07 14:37:23 +02:00
14 changed files with 207 additions and 76 deletions

View File

@@ -449,7 +449,7 @@ install' _ (_, ListResult {..}) = do
case lTool of case lTool of
GHC -> do GHC -> do
let vi = getVersionInfo lVer GHC dls let vi = getVersionInfo lVer GHC dls
liftE $ installGHCBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce)
Cabal -> do Cabal -> do
let vi = getVersionInfo lVer Cabal dls let vi = getVersionInfo lVer Cabal dls
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)

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
@@ -232,7 +234,7 @@ ghcCompileOpts =
"Build cross-compiler for this platform" "Build cross-compiler for this platform"
) )
) )
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)")) <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to compile configure, prefix with '-- ' (longopts)"))
<*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install")) <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install"))
<*> optional <*> optional
(option (option
@@ -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

@@ -71,6 +71,7 @@ data InstallOptions = InstallOptions
, instSet :: Bool , instSet :: Bool
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
, forceInstall :: Bool , forceInstall :: Bool
, addConfArgs :: [T.Text]
} }
@@ -213,6 +214,7 @@ installOpts tool =
) )
<*> switch <*> switch
(short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)") (short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)")
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to bindist configure, prefix with '-- ' (longopts)"))
where where
setDefault = case tool of setDefault = case tool of
Nothing -> False Nothing -> False
@@ -335,6 +337,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(_tvVersion v) (_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
addConfArgs
) )
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
pure vi pure vi
@@ -346,6 +349,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(_tvVersion v) (_tvVersion v)
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
addConfArgs
) )
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
pure vi pure vi

View File

@@ -361,6 +361,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
(_tvVersion v) (_tvVersion v)
GHCupInternal GHCupInternal
False False
[]
setTool GHC v tmp setTool GHC v tmp
Just (Cabal, v) -> do Just (Cabal, v) -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin

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

@@ -141,6 +141,7 @@ installGHCBindist :: ( MonadFail m
-> Version -- ^ the version to install -> Version -- ^ the version to install
-> InstallDir -> InstallDir
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
@@ -159,7 +160,7 @@ installGHCBindist :: ( MonadFail m
] ]
m m
() ()
installGHCBindist dlinfo ver installDir forceInstall = do installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do
let tver = mkTVer ver let tver = mkTVer ver
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
@@ -189,12 +190,12 @@ installGHCBindist dlinfo ver installDir forceInstall = do
case installDir of case installDir of
IsolateDir isoDir -> do -- isolated install IsolateDir isoDir -> do -- isolated install
lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall addConfArgs
GHCupInternal -> do -- regular install GHCupInternal -> do -- regular install
-- prepare paths -- prepare paths
ghcdir <- lift $ ghcupGHCDir tver ghcdir <- lift $ ghcupGHCDir tver
liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall addConfArgs
-- make symlinks & stuff when regular install, -- make symlinks & stuff when regular install,
liftE $ postGHCInstall tver liftE $ postGHCInstall tver
@@ -230,6 +231,7 @@ installPackedGHC :: ( MonadMask m
-> InstallDirResolved -> InstallDirResolved
-> Version -- ^ The GHC version -> Version -- ^ The GHC version
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist
-> Excepts -> Excepts
'[ BuildFailed '[ BuildFailed
, UnknownArchive , UnknownArchive
@@ -239,7 +241,7 @@ installPackedGHC :: ( MonadMask m
, ProcessError , ProcessError
, MergeFileTreeError , MergeFileTreeError
] m () ] m ()
installPackedGHC dl msubdir inst ver forceInstall = do installPackedGHC dl msubdir inst ver forceInstall addConfArgs = do
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
unless forceInstall unless forceInstall
@@ -256,7 +258,7 @@ installPackedGHC dl msubdir inst ver forceInstall = do
msubdir msubdir
liftE $ runBuildAction tmpUnpack liftE $ runBuildAction tmpUnpack
(installUnpackedGHC workdir inst ver forceInstall) (installUnpackedGHC workdir inst ver forceInstall addConfArgs)
-- | Install an unpacked GHC distribution. This only deals with the GHC -- | Install an unpacked GHC distribution. This only deals with the GHC
@@ -277,8 +279,9 @@ installUnpackedGHC :: ( MonadReader env m
-> InstallDirResolved -- ^ Path to install to -> InstallDirResolved -- ^ Path to install to
-> Version -- ^ The GHC version -> Version -- ^ The GHC version
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist
-> Excepts '[ProcessError, MergeFileTreeError] m () -> Excepts '[ProcessError, MergeFileTreeError] m ()
installUnpackedGHC path inst ver forceInstall installUnpackedGHC path inst ver forceInstall addConfArgs
| isWindows = do | isWindows = do
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need -- Windows bindists are relocatable and don't need
@@ -301,7 +304,7 @@ installUnpackedGHC path inst ver forceInstall
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh" lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> fromInstallDir inst) ("./configure" : ("--prefix=" <> fromInstallDir inst)
: alpineArgs : (alpineArgs <> (T.unpack <$> addConfArgs))
) )
(Just $ fromGHCupPath path) (Just $ fromGHCupPath path)
"ghc-configure" "ghc-configure"
@@ -342,6 +345,7 @@ installGHCBin :: ( MonadFail m
=> Version -- ^ the version to install => Version -- ^ the version to install
-> InstallDir -> InstallDir
-> Bool -- ^ force install -> Bool -- ^ force install
-> [T.Text] -- ^ additional configure args for bindist
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, BuildFailed , BuildFailed
@@ -360,9 +364,9 @@ installGHCBin :: ( MonadFail m
] ]
m m
() ()
installGHCBin ver installDir forceInstall = do installGHCBin ver installDir forceInstall addConfArgs = do
dlinfo <- liftE $ getDownloadInfo GHC ver dlinfo <- liftE $ getDownloadInfo GHC ver
liftE $ installGHCBindist dlinfo ver installDir forceInstall liftE $ installGHCBindist dlinfo ver installDir forceInstall addConfArgs
@@ -562,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
@@ -677,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
@@ -747,6 +779,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
ghcdir ghcdir
(installVer ^. tvVersion) (installVer ^. tvVersion)
False -- not a force install, since we already overwrite when compiling. False -- not a force install, since we already overwrite when compiling.
[]
liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk

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

@@ -211,8 +211,8 @@ exec exe args chdir env = do
let paths = ["PATH", "Path"] let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] curPaths newPath = intercalate [searchPathSeparator] curPaths
setEnv "PATH" "" liftIO $ setEnv "PATH" ""
setEnv "Path" newPath 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
@@ -230,8 +230,8 @@ execNoMinGW exe args chdir env = do
let paths = ["PATH", "Path"] let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] curPaths newPath = intercalate [searchPathSeparator] curPaths
setEnv "PATH" "" liftIO $ setEnv "PATH" ""
setEnv "Path" newPath liftIO $ setEnv "Path" newPath
let cp = (proc exe args) { cwd = chdir, env = env } let cp = (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
@@ -257,8 +257,9 @@ createProcessWithMingwPath :: MonadIO m
createProcessWithMingwPath cp = do createProcessWithMingwPath cp = do
msys2Dir <- liftIO ghcupMsys2Dir msys2Dir <- liftIO ghcupMsys2Dir
cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp) cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
let mingWPaths = [msys2Dir </> "usr" </> "bin" let mingWPaths = [msys2Dir </> "mingw64" </> "bin"
,msys2Dir </> "mingw64" </> "bin"] ,msys2Dir </> "usr" </> "bin"
]
paths = ["PATH", "Path"] paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths) newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)

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

@@ -546,7 +546,7 @@ adjust_cabal_config() {
else else
cabal_bin="$HOME/AppData/Roaming/cabal/bin" cabal_bin="$HOME/AppData/Roaming/cabal/bin"
fi fi
ecabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$cabal_bin"), $(cygpath -w "$GHCUP_MSYS2"/usr/bin), $(cygpath -w "$GHCUP_MSYS2"/mingw64/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() {
@@ -697,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"
@@ -772,7 +772,7 @@ if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
do_cabal_config_init $ask_cabal_config_init_answer do_cabal_config_init $ask_cabal_config_init_answer
ecabal update --ignore-project edo cabal update --ignore-project
else # don't install ghc and cabal else # don't install ghc and cabal
case "${plat}" in case "${plat}" in
MSYS*|MINGW*) MSYS*|MINGW*)

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