Compare commits
15 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
13e01ab453
|
|||
|
873dd77a6f
|
|||
|
544c618473
|
|||
|
a264cb088e
|
|||
|
1a43fddca9
|
|||
|
bdfb1a3a9b
|
|||
|
9b8b3e8126
|
|||
|
d657c17df4
|
|||
|
|
e143c06697 | ||
|
|
29da21f5dc | ||
|
028696d4be
|
|||
|
4022edb12e
|
|||
|
fde5044194
|
|||
|
3af1286ab7
|
|||
|
bcff46d3d4
|
@@ -449,7 +449,7 @@ install' _ (_, ListResult {..}) = do
|
||||
case lTool of
|
||||
GHC -> do
|
||||
let vi = getVersionInfo lVer GHC dls
|
||||
liftE $ installGHCBin lVer GHCupInternal False $> (vi, dirs, ce)
|
||||
liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce)
|
||||
Cabal -> do
|
||||
let vi = getVersionInfo lVer Cabal dls
|
||||
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
|
||||
|
||||
@@ -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
|
||||
@@ -232,7 +234,7 @@ ghcCompileOpts =
|
||||
"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"))
|
||||
<*> optional
|
||||
(option
|
||||
@@ -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)
|
||||
|
||||
@@ -71,6 +71,7 @@ data InstallOptions = InstallOptions
|
||||
, instSet :: Bool
|
||||
, isolateDir :: Maybe FilePath
|
||||
, forceInstall :: Bool
|
||||
, addConfArgs :: [T.Text]
|
||||
}
|
||||
|
||||
|
||||
@@ -213,6 +214,7 @@ installOpts tool =
|
||||
)
|
||||
<*> switch
|
||||
(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
|
||||
setDefault = case tool of
|
||||
Nothing -> False
|
||||
@@ -335,6 +337,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
(_tvVersion v)
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
addConfArgs
|
||||
)
|
||||
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
|
||||
pure vi
|
||||
@@ -346,6 +349,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
||||
(_tvVersion v)
|
||||
(maybe GHCupInternal IsolateDir isolateDir)
|
||||
forceInstall
|
||||
addConfArgs
|
||||
)
|
||||
$ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing
|
||||
pure vi
|
||||
|
||||
@@ -361,6 +361,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
|
||||
(_tvVersion v)
|
||||
GHCupInternal
|
||||
False
|
||||
[]
|
||||
setTool GHC v tmp
|
||||
Just (Cabal, v) -> do
|
||||
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -74,12 +74,15 @@ cabal-install/HLS/stack are installed in `~/.ghcup/bin/<tool>-<ver>` and have un
|
||||
|
||||
## Known users
|
||||
|
||||
* Github actions:
|
||||
- [actions/virtual-environments](https://github.com/actions/virtual-environments)
|
||||
- [haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
|
||||
* CI:
|
||||
- [Github actions/virtual-environments](https://github.com/actions/virtual-environments)
|
||||
- [Github haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
|
||||
- [haskell-ci](https://github.com/haskell-CI/haskell-ci)
|
||||
* mirrors:
|
||||
- [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
|
||||
* 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)
|
||||
|
||||
## Known problems
|
||||
|
||||
@@ -200,6 +200,14 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
|
||||
|
||||
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
|
||||
|
||||
* [Libera IRC chat on #haskell-ghcup or #haskell](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -141,6 +141,7 @@ installGHCBindist :: ( MonadFail m
|
||||
-> Version -- ^ the version to install
|
||||
-> InstallDir
|
||||
-> Bool -- ^ Force install
|
||||
-> [T.Text] -- ^ additional configure args for bindist
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
@@ -159,7 +160,7 @@ installGHCBindist :: ( MonadFail m
|
||||
]
|
||||
m
|
||||
()
|
||||
installGHCBindist dlinfo ver installDir forceInstall = do
|
||||
installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do
|
||||
let tver = mkTVer ver
|
||||
|
||||
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
|
||||
@@ -189,12 +190,12 @@ installGHCBindist dlinfo ver installDir forceInstall = do
|
||||
case installDir of
|
||||
IsolateDir isoDir -> do -- isolated install
|
||||
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
|
||||
-- prepare paths
|
||||
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,
|
||||
liftE $ postGHCInstall tver
|
||||
@@ -230,6 +231,7 @@ installPackedGHC :: ( MonadMask m
|
||||
-> InstallDirResolved
|
||||
-> Version -- ^ The GHC version
|
||||
-> Bool -- ^ Force install
|
||||
-> [T.Text] -- ^ additional configure args for bindist
|
||||
-> Excepts
|
||||
'[ BuildFailed
|
||||
, UnknownArchive
|
||||
@@ -239,7 +241,7 @@ installPackedGHC :: ( MonadMask m
|
||||
, ProcessError
|
||||
, MergeFileTreeError
|
||||
] m ()
|
||||
installPackedGHC dl msubdir inst ver forceInstall = do
|
||||
installPackedGHC dl msubdir inst ver forceInstall addConfArgs = do
|
||||
PlatformRequest {..} <- lift getPlatformReq
|
||||
|
||||
unless forceInstall
|
||||
@@ -256,7 +258,7 @@ installPackedGHC dl msubdir inst ver forceInstall = do
|
||||
msubdir
|
||||
|
||||
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
|
||||
@@ -277,8 +279,9 @@ installUnpackedGHC :: ( MonadReader env m
|
||||
-> InstallDirResolved -- ^ Path to install to
|
||||
-> Version -- ^ The GHC version
|
||||
-> Bool -- ^ Force install
|
||||
-> [T.Text] -- ^ additional configure args for bindist
|
||||
-> Excepts '[ProcessError, MergeFileTreeError] m ()
|
||||
installUnpackedGHC path inst ver forceInstall
|
||||
installUnpackedGHC path inst ver forceInstall addConfArgs
|
||||
| isWindows = do
|
||||
lift $ logInfo "Installing GHC (this may take a while)"
|
||||
-- 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)"
|
||||
lEM $ execLogged "sh"
|
||||
("./configure" : ("--prefix=" <> fromInstallDir inst)
|
||||
: alpineArgs
|
||||
: (alpineArgs <> (T.unpack <$> addConfArgs))
|
||||
)
|
||||
(Just $ fromGHCupPath path)
|
||||
"ghc-configure"
|
||||
@@ -342,6 +345,7 @@ installGHCBin :: ( MonadFail m
|
||||
=> Version -- ^ the version to install
|
||||
-> InstallDir
|
||||
-> Bool -- ^ force install
|
||||
-> [T.Text] -- ^ additional configure args for bindist
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, BuildFailed
|
||||
@@ -360,9 +364,9 @@ installGHCBin :: ( MonadFail m
|
||||
]
|
||||
m
|
||||
()
|
||||
installGHCBin ver installDir forceInstall = do
|
||||
installGHCBin ver installDir forceInstall addConfArgs = do
|
||||
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
|
||||
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
|
||||
@@ -677,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
|
||||
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
|
||||
@@ -747,6 +779,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
|
||||
ghcdir
|
||||
(installVer ^. tvVersion)
|
||||
False -- not a force install, since we already overwrite when compiling.
|
||||
[]
|
||||
|
||||
liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk
|
||||
|
||||
|
||||
@@ -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
|
||||
@@ -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,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
|
||||
|
||||
@@ -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
|
||||
@@ -257,8 +257,9 @@ createProcessWithMingwPath :: MonadIO m
|
||||
createProcessWithMingwPath cp = do
|
||||
msys2Dir <- liftIO ghcupMsys2Dir
|
||||
cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
|
||||
let mingWPaths = [msys2Dir </> "usr" </> "bin"
|
||||
,msys2Dir </> "mingw64" </> "bin"]
|
||||
let mingWPaths = [msys2Dir </> "mingw64" </> "bin"
|
||||
,msys2Dir </> "usr" </> "bin"
|
||||
]
|
||||
paths = ["PATH", "Path"]
|
||||
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
|
||||
newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -546,7 +546,7 @@ adjust_cabal_config() {
|
||||
else
|
||||
cabal_bin="$HOME/AppData/Roaming/cabal/bin"
|
||||
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() {
|
||||
@@ -697,7 +697,7 @@ find_shell
|
||||
echo
|
||||
echo "Welcome to Haskell!"
|
||||
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 " * ghc - The Glasgow Haskell Compiler"
|
||||
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
|
||||
|
||||
ecabal update --ignore-project
|
||||
edo cabal update --ignore-project
|
||||
else # don't install ghc and cabal
|
||||
case "${plat}" in
|
||||
MSYS*|MINGW*)
|
||||
|
||||
@@ -242,7 +242,7 @@ if ($Silent -and !($InstallDir)) {
|
||||
Print-Msg -color Magenta -msg (@'
|
||||
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
|
||||
* ghc - The Glasgow Haskell Compiler
|
||||
* msys2 - A linux-style toolchain environment required for many operations
|
||||
|
||||
Reference in New Issue
Block a user