Merge branch 'hls-hackage'

This commit is contained in:
Julian Ospald 2022-07-12 00:06:40 +02:00
commit 2f299ee48d
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
9 changed files with 265 additions and 77 deletions

View File

@ -440,9 +440,11 @@ tagCompleter tool add = listIOCompleter $ do
pure $ nub $ (add ++) $ fmap tagToString allTags pure $ nub $ (add ++) $ fmap tagToString allTags
VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add) VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add)
versionCompleter :: Maybe ListCriteria -> Tool -> Completer versionCompleter :: Maybe ListCriteria -> Tool -> Completer
versionCompleter criteria tool = listIOCompleter $ do versionCompleter criteria tool = versionCompleter' criteria tool (const True)
versionCompleter' :: Maybe ListCriteria -> Tool -> (Version -> Bool) -> Completer
versionCompleter' criteria tool filter' = listIOCompleter $ do
dirs' <- liftIO getAllDirs dirs' <- liftIO getAllDirs
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = False { lcPrintDebug = False
@ -471,7 +473,7 @@ versionCompleter criteria tool = listIOCompleter $ do
runEnv = flip runReaderT appState runEnv = flip runReaderT appState
installedVersions <- runEnv $ listVersions (Just tool) criteria installedVersions <- runEnv $ listVersions (Just tool) criteria
return $ T.unpack . prettyVer . lVer <$> installedVersions return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions
toolDlCompleter :: Tool -> Completer toolDlCompleter :: Tool -> Completer

View File

@ -12,6 +12,8 @@ module GHCup.OptParse.Compile where
import GHCup import GHCup
import qualified GHCup.GHC as GHC
import qualified GHCup.HLS as HLS
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
@ -30,7 +32,8 @@ import Control.Monad.Trans.Resource
import Data.Bifunctor import Data.Bifunctor
import Data.Functor import Data.Functor
import Data.Maybe import Data.Maybe
import Data.Versions ( Version, prettyVer, version ) import Data.Versions ( Version, prettyVer, version, pvp )
import qualified Data.Versions as V
import Data.Text ( Text ) import Data.Text ( Text )
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
@ -41,7 +44,7 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow )
import URI.ByteString hiding ( uriParser ) import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception.Safe (MonadMask) import Control.Exception.Safe (MonadMask, displayException)
import System.FilePath (isPathSeparator) import System.FilePath (isPathSeparator)
import Text.Read (readEither) import Text.Read (readEither)
@ -64,7 +67,7 @@ data CompileCommand = CompileGHC GHCCompileOptions
data GHCCompileOptions = GHCCompileOptions data GHCCompileOptions = GHCCompileOptions
{ targetGhc :: Either Version GitBranch { targetGhc :: GHC.GHCVer Version
, bootstrapGhc :: Either Version FilePath , bootstrapGhc :: Either Version FilePath
, jobs :: Maybe Int , jobs :: Maybe Int
, buildConfig :: Maybe FilePath , buildConfig :: Maybe FilePath
@ -78,10 +81,12 @@ data GHCCompileOptions = GHCCompileOptions
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
} }
data HLSCompileOptions = HLSCompileOptions data HLSCompileOptions = HLSCompileOptions
{ targetHLS :: Either Version GitBranch { targetHLS :: HLS.HLSVer
, jobs :: Maybe Int , jobs :: Maybe Int
, setCompile :: Bool , setCompile :: Bool
, updateCabal :: Bool
, ovewrwiteVer :: Either Bool Version , ovewrwiteVer :: Either Bool Version
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
, cabalProject :: Maybe (Either FilePath URI) , cabalProject :: Maybe (Either FilePath URI)
@ -149,10 +154,10 @@ Examples:
These need to be available in PATH prior to compilation. These need to be available in PATH prior to compilation.
Examples: Examples:
# compile 1.7.0.0 for ghc 8.10.5 and 8.10.7, passing '--allow-newer' to cabal # compile 1.7.0.0 from hackage for 8.10.7, running 'cabal update' before the build
ghcup compile hls -v 1.7.0.0 -j 12 --ghc 8.10.5 --ghc 8.10.7 -- --allow-newer ghcup compile hls --version 1.7.0.0 --ghc 8.10.7 --cabal-update
# compile from master for ghc 9.2.3 and use 'git describe' to name the binary # compile from master for ghc 9.2.3 using 'git describe' to name the binary and ignore the pinned index state
ghcup compile hls -g master --git-describe-version --ghc 9.2.3 ghcup compile hls -g master --git-describe-version --ghc 9.2.3 -- --index-state=@(date '+%s')
# compile a specific commit for ghc 9.2.3 and set a specifc version for the binary name # 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|] ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|]
@ -160,7 +165,7 @@ Examples:
ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts :: Parser GHCCompileOptions
ghcCompileOpts = ghcCompileOpts =
GHCCompileOptions GHCCompileOptions
<$> ((Left <$> option <$> ((GHC.SourceDist <$> option
(eitherReader (eitherReader
(first (const "Not a valid version") . version . T.pack) (first (const "Not a valid version") . version . T.pack)
) )
@ -169,7 +174,7 @@ ghcCompileOpts =
<> (completer $ versionCompleter Nothing GHC) <> (completer $ versionCompleter Nothing GHC)
) )
) <|> ) <|>
(Right <$> (GitBranch <$> option (GHC.GitDist <$> (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"
@ -178,7 +183,18 @@ ghcCompileOpts =
short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)" short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"
<> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"]) <> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"])
)) ))
))) ))
<|>
(
GHC.RemoteDist <$> (option
(eitherReader uriParser)
(long "remote-source-dist" <> metavar "URI" <> help
"URI (https/http/file) to a GHC source distribution"
<> completer fileUri
)
)
)
)
<*> option <*> option
(eitherReader (eitherReader
(\x -> (\x ->
@ -270,16 +286,17 @@ ghcCompileOpts =
hlsCompileOpts :: Parser HLSCompileOptions hlsCompileOpts :: Parser HLSCompileOptions
hlsCompileOpts = hlsCompileOpts =
HLSCompileOptions HLSCompileOptions
<$> ((Left <$> option <$> ((HLS.HackageDist <$> option
(eitherReader (eitherReader
(first (const "Not a valid version") . version . T.pack) ((>>= first displayException . V.version . V.prettyPVP) . first (const "Not a valid PVP version") . pvp . T.pack)
) )
(short 'v' <> long "version" <> metavar "VERSION" <> help (short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile" "The version to compile (pulled from hackage)"
<> (completer $ versionCompleter Nothing HLS) <> (completer $ versionCompleter' Nothing HLS (either (const False) (const True) . V.pvp . V.prettyVer))
) )
) <|> )
(Right <$> (GitBranch <$> option <|>
(HLS.GitDist <$> (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 (accepts anything 'git checkout' accepts)" "The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)"
@ -287,7 +304,28 @@ hlsCompileOpts =
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"])
)) ))
))) ))
<|>
(HLS.SourceDist <$> (option
(eitherReader
(first (const "Not a valid version") . version . T.pack)
)
(long "source-dist" <> metavar "VERSION" <> help
"The version to compile (pulled from packaged git sources)"
<> (completer $ versionCompleter Nothing HLS)
)
))
<|>
(
HLS.RemoteDist <$> (option
(eitherReader uriParser)
(long "remote-source-dist" <> metavar "URI" <> help
"URI (https/http/file) to a HLS source distribution"
<> completer fileUri
)
)
)
)
<*> optional <*> optional
(option (option
(eitherReader (readEither @Int)) (eitherReader (readEither @Int))
@ -297,6 +335,7 @@ 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"))
<*> switch (long "cabal-update" <> help "Run 'cabal update' before the build")
<*> <*>
( (
(Right <$> option (Right <$> option
@ -468,7 +507,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
(CompileHLS HLSCompileOptions { .. }) -> do (CompileHLS HLSCompileOptions { .. }) -> do
runCompileHLS runAppState (do runCompileHLS runAppState (do
case targetHLS of case targetHLS of
Left targetVer -> do HLS.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls let vi = getVersionInfo targetVer HLS dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
@ -476,7 +515,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
lift $ logInfo lift $ logInfo
"...waiting for 5 seconds, you can still abort..." "...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure () _ -> pure ()
ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC) ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC)
targetVer <- liftE $ compileHLS targetVer <- liftE $ compileHLS
targetHLS targetHLS
@ -486,6 +525,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
cabalProject cabalProject
cabalProjectLocal cabalProjectLocal
updateCabal
patches patches
cabalArgs cabalArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@ -519,7 +559,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
(CompileGHC GHCCompileOptions {..}) -> (CompileGHC GHCCompileOptions {..}) ->
runCompileGHC runAppState (do runCompileGHC runAppState (do
case targetGhc of case targetGhc of
Left targetVer -> do GHC.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
@ -527,9 +567,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
lift $ logInfo lift $ logInfo
"...waiting for 5 seconds, you can still abort..." "...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure () _ -> pure ()
targetVer <- liftE $ compileGHC targetVer <- liftE $ compileGHC
(first (GHCTargetVersion crossTarget) targetGhc) ((\case
GHC.SourceDist v -> GHC.SourceDist $ GHCTargetVersion crossTarget v
GHC.GitDist g -> GHC.GitDist g
GHC.RemoteDist r -> GHC.RemoteDist r) targetGhc)
ovewrwiteVer ovewrwiteVer
bootstrapGhc bootstrapGhc
jobs jobs

View File

@ -14,6 +14,8 @@ module Main where
import BrickMain ( brickMain ) import BrickMain ( brickMain )
#endif #endif
import qualified GHCup.GHC as GHC
import qualified GHCup.HLS as HLS
import GHCup.OptParse import GHCup.OptParse
import GHCup.Download import GHCup.Download
@ -338,11 +340,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver
alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over })) alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))
(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 = GHC.SourceDist tver }))
(GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right 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 = HLS.SourceDist tver }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.HackageDist tver }))
(HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver
alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True
alreadyInstalling _ _ = pure False alreadyInstalling _ _ = pure False

View File

@ -202,7 +202,9 @@ and produce the binaries `ghc-8.10.2-eff` and `ghc-head` respectively.
GHCup always needs to know which version the bindist corresponds to (this is not automatically GHCup always needs to know which version the bindist corresponds to (this is not automatically
detected). detected).
## Compiling GHC from source ## Compiling from source
### GHC
Compiling from source is supported for both source tarballs and arbitrary git refs. See `ghcup compile ghc --help` Compiling from source is supported for both source tarballs and arbitrary git refs. See `ghcup compile ghc --help`
for a list of all available options. for a list of all available options.
@ -214,6 +216,47 @@ Common `build.mk` options are explained [here](https://gitlab.haskell.org/ghc/gh
Make sure your system meets all the [prerequisites](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/preparation). Make sure your system meets all the [prerequisites](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/preparation).
### HLS
There are 3 main ways to compile HLS from source.
1. from hackage (should have up to date version bounds)
- `ghcup compile hls --version 1.7.0.0 --ghc 9.2.3`
2. from git (allows to build latest sources and PRs)
- `ghcup compile hls --git-ref master --ghc 9.2.3`
- `ghcup compile hls --git-ref a32db0b --ghc 9.2.3`
- `ghcup compile hls --git-ref 1.7.0.0 --ghc 9.2.3`
3. from source distribution that's packaged during release from the corresponding git sources
- `ghcup compile hls --source-dist 1.7.0.0 --ghc 9.2.3`
All these use `cabal v2-install` under the hood, so all build components are cached.
You can pass arbitrary arguments to cabal, e.g. set the index state like so:
```sh
ghcup compile hls --git-ref master --ghc 9.2.3 -- --index-state=2022-06-12T00:00:00Z --allow-newer
```
You can pass `--ghc <ver>` multiple times to install for many GHCs at once.
When building from git sources, ghcup will auto-detect the HLS version that the git commit corresponds to
from the `haskell-language-server.cabal` file. This version might not have been updated since the last release.
If you want to avoid overwriting the existing installed HLS version, you can instruct ghcup to use `git describe`
to set the HLS version instead:
```sh
ghcup compile hls --git-ref master --ghc 9.2.3 --git-describe-version
```
You can also set the version explicitly:
```sh
ghcup compile hls --git-ref master --ghc 9.2.3 --overwrite-version 1.7.0.0-p1
```
To instruct cabal to run `cabal update` before building, run `ghcup compile hls --version 1.7.0.0 --ghc 9.2.3 --cabal-update`
As always, check `ghcup compile hls --help`.
### Cross support ### Cross support
ghcup can compile and install a cross GHC for any target. However, this ghcup can compile and install a cross GHC for any target. However, this

View File

@ -33,8 +33,8 @@ module GHCup (
import GHCup.Cabal import GHCup.Cabal
import GHCup.GHC import GHCup.GHC hiding ( GHCVer(..) )
import GHCup.HLS import GHCup.HLS hiding ( HLSVer(..) )
import GHCup.Stack import GHCup.Stack
import GHCup.List import GHCup.List
import GHCup.Download import GHCup.Download
@ -206,9 +206,8 @@ rmGhcupDirs = do
| isWindows = removeDirIfEmptyOrIsSymlink binDir | isWindows = removeDirIfEmptyOrIsSymlink binDir
| otherwise = do | otherwise = do
isXDGStyle <- liftIO useXDG isXDGStyle <- liftIO useXDG
if not isXDGStyle when (not isXDGStyle) $
then removeDirIfEmptyOrIsSymlink binDir removeDirIfEmptyOrIsSymlink binDir
else pure ()
reportRemainingFiles :: (MonadMask m, MonadIO m) => FilePath -> m [FilePath] reportRemainingFiles :: (MonadMask m, MonadIO m) => FilePath -> m [FilePath]
reportRemainingFiles dir = do reportRemainingFiles dir = do

View File

@ -80,6 +80,12 @@ import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
data GHCVer v = SourceDist v
| GitDist GitBranch
| RemoteDist URI
--------------------- ---------------------
--[ Tool fetching ]-- --[ Tool fetching ]--
--------------------- ---------------------
@ -607,7 +613,7 @@ compileGHC :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
=> Either GHCTargetVersion GitBranch -- ^ version to install => GHCVer GHCTargetVersion
-> Maybe Version -- ^ overwrite version -> Maybe Version -- ^ overwrite version
-> Either Version FilePath -- ^ version to bootstrap with -> Either Version FilePath -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs -> Maybe Int -- ^ jobs
@ -650,7 +656,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
(workdir, tmpUnpack, tver) <- case targetGhc of (workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball -- unpack from version tarball
Left tver -> do SourceDist tver -> do
lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
-- download source tarball -- download source tarball
@ -671,8 +677,31 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
pure (workdir, tmpUnpack, tver) pure (workdir, tmpUnpack, tver)
RemoteDist uri -> do
lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
-- download source tarball
tmpDownload <- lift withGHCupTmpDir
tmpUnpack <- lift mkGhcupTmpDir
tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
(bf, tver) <- liftE $ cleanUpOnError @'[UnknownArchive, ArchiveResult, ProcessError] tmpUnpack $ do
liftE $ unpackToDir (fromGHCupPath tmpUnpack) tar
let regex = [s|^(.*/)*boot$|] :: B.ByteString
[bootFile] <- liftIO $ findFilesDeep
tmpUnpack
(makeRegexOpts compExtended
execBlank
regex
)
tver <- liftE $ getGHCVer (appendGHCupPath tmpUnpack (takeDirectory bootFile))
pure (bootFile, tver)
let workdir = appendGHCupPath tmpUnpack (takeDirectory bf)
pure (workdir, tmpUnpack, mkTVer tver)
-- clone from git -- clone from git
Right GitBranch{..} -> do GitDist 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 @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do
@ -715,14 +744,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack)
-- bootstrap -- bootstrap
lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" tver <- liftE $ getGHCVer tmpUnpack
lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"
CapturedProcess {..} <- lift $ makeOut
["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)
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) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <> lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <>
"GHC version (from Makefile): " <> prettyVer tver <> "GHC version (from Makefile): " <> prettyVer tver <>
@ -795,11 +817,29 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
pure installVer pure installVer
where where
getGHCVer :: ( MonadReader env m
, HasSettings env
, HasDirs env
, HasLog env
, MonadIO m
, MonadThrow m
)
=> GHCupPath
-> Excepts '[ProcessError] m Version
getGHCVer tmpUnpack = do
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 "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
ExitFailure c -> throwE $ NonZeroExit c "make" ["show!", "--quiet", "VALUE=ProjectVersion" ]
defaultConf = defaultConf =
let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross")))
default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))
in case targetGhc of in case targetGhc of
Left (GHCTargetVersion (Just _) _) -> cross_mk SourceDist (GHCTargetVersion (Just _) _) -> cross_mk
_ -> default_mk _ -> default_mk
compileHadrianBindist :: ( MonadReader env m compileHadrianBindist :: ( MonadReader env m
@ -976,7 +1016,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
-- for cross, we need Stage1Only -- for cross, we need Stage1Only
case targetGhc of case targetGhc of
Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE SourceDist (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
(InvalidBuildConfig (InvalidBuildConfig
[s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
) )

View File

@ -71,6 +71,12 @@ import qualified Text.Megaparsec as MP
import Text.PrettyPrint.HughesPJClass (prettyShow) import Text.PrettyPrint.HughesPJClass (prettyShow)
data HLSVer = SourceDist Version
| GitDist GitBranch
| HackageDist Version
| RemoteDist URI
-------------------- --------------------
--[ Installation ]-- --[ Installation ]--
@ -324,13 +330,14 @@ compileHLS :: ( MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
=> Either Version GitBranch => HLSVer
-> [Version] -> [Version]
-> Maybe Int -> Maybe Int
-> Either Bool Version -> Either Bool Version
-> InstallDir -> InstallDir
-> Maybe (Either FilePath URI) -> Maybe (Either FilePath URI)
-> Maybe URI -> Maybe URI
-> Bool
-> Maybe (Either FilePath [URI]) -- ^ patches -> Maybe (Either FilePath [URI]) -- ^ patches
-> [Text] -- ^ additional args to cabal install -> [Text] -- ^ additional args to cabal install
-> Excepts '[ NoDownload -> Excepts '[ NoDownload
@ -343,15 +350,18 @@ compileHLS :: ( MonadMask m
, BuildFailed , BuildFailed
, NotInstalled , NotInstalled
] m Version ] m Version
compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do
PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
Dirs { .. } <- lift getDirs Dirs { .. } <- lift getDirs
when updateCabal $ reThrowAll @_ @'[ProcessError] DownloadFailed $ do
lift $ logInfo "Updating cabal DB"
lEM $ exec "cabal" ["update"] (Just $ fromGHCupPath tmpDir) Nothing
(workdir, tver, git_describe) <- case targetHLS of (workdir, tmpUnpack, tver, git_describe) <- case targetHLS of
-- unpack from version tarball -- unpack from version tarball
Left tver -> do SourceDist tver -> do
lift $ logDebug $ "Requested to compile: " <> prettyVer tver lift $ logDebug $ "Requested to compile: " <> prettyVer tver
-- download source tarball -- download source tarball
@ -369,10 +379,47 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
(liftE . intoSubdir tmpUnpack) (liftE . intoSubdir tmpUnpack)
(view dlSubdir dlInfo) (view dlSubdir dlInfo)
pure (workdir, tver, Nothing) pure (workdir, tmpUnpack, tver, Nothing)
HackageDist tver -> do
lift $ logDebug $ "Requested to compile (from hackage): " <> prettyVer tver
-- download source tarball
tmpUnpack <- lift mkGhcupTmpDir
let hls = "haskell-language-server-" <> T.unpack (prettyVer tver)
reThrowAll @_ @'[ProcessError] DownloadFailed $ do
-- unpack
lEM $ exec "cabal" ["unpack", hls] (Just $ fromGHCupPath tmpUnpack) Nothing
let workdir = appendGHCupPath tmpUnpack hls
pure (workdir, tmpUnpack, tver, Nothing)
RemoteDist uri -> do
lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)
-- download source tarball
tmpDownload <- lift withGHCupTmpDir
tmpUnpack <- lift mkGhcupTmpDir
tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False
(cf, tver) <- liftE $ cleanUpOnError tmpUnpack $ do
unpackToDir (fromGHCupPath tmpUnpack) tar
let regex = [s|^(.*/)*haskell-language-server\.cabal$|] :: B.ByteString
[cabalFile] <- liftIO $ findFilesDeep
tmpUnpack
(makeRegexOpts compExtended
execBlank
regex
)
tver <- getCabalVersion (fromGHCupPath tmpUnpack </> cabalFile)
pure (cabalFile, tver)
let workdir = appendGHCupPath tmpUnpack (takeDirectory cf)
pure (workdir, tmpUnpack, tver, Nothing)
-- clone from git -- clone from git
Right GitBranch{..} -> do GitDist 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
reThrowAll @_ @'[ProcessError] DownloadFailed $ do reThrowAll @_ @'[ProcessError] DownloadFailed $ do
@ -409,15 +456,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
then pure Nothing then pure Nothing
else fmap Just $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack) else fmap Just $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)
chash <- gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack) chash <- gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)
(Just gpd) <- parseGenericPackageDescriptionMaybe tver <- getCabalVersion (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal")
<$> 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
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)
lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <> lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <>
@ -425,7 +464,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
(if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <> (if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <>
(if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash) (if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash)
pure (tmpUnpack, tver, git_describe) pure (tmpUnpack, 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
@ -441,7 +480,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
Right v -> pure v Right v -> pure v
liftE $ runBuildAction liftE $ runBuildAction
workdir tmpUnpack
(reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do
let tmpInstallDir = fromGHCupPath workdir </> "out" let tmpInstallDir = fromGHCupPath workdir </> "out"
liftIO $ createDirRecursive' tmpInstallDir liftIO $ createDirRecursive' tmpInstallDir
@ -457,14 +496,22 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patc
pure "cabal.project" pure "cabal.project"
| otherwise -> pure (takeFileName cp) | otherwise -> pure (takeFileName cp)
Just (Right uri) -> do Just (Right uri) -> do
tmpUnpack <- lift withGHCupTmpDir tmpUnpack' <- lift withGHCupTmpDir
cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just "cabal.project") False
copyFileE cp (fromGHCupPath workdir </> "cabal.project") False copyFileE cp (fromGHCupPath workdir </> "cabal.project") False
pure "cabal.project" pure "cabal.project"
Nothing -> pure "cabal.project" Nothing
| HackageDist _ <- targetHLS -> do
liftIO $ B.writeFile (fromGHCupPath workdir </> "cabal.project") "packages: ./"
pure "cabal.project"
| RemoteDist _ <- targetHLS -> do
let cabalFile = fromGHCupPath workdir </> "cabal.project"
liftIO $ whenM (not <$> doesFileExist cabalFile) $ B.writeFile cabalFile "packages: ./"
pure "cabal.project"
| otherwise -> pure "cabal.project"
forM_ cabalProjectLocal $ \uri -> do forM_ cabalProjectLocal $ \uri -> do
tmpUnpack <- lift withGHCupTmpDir tmpUnpack' <- lift withGHCupTmpDir
cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just (cp <.> "local")) False
copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False
artifacts <- forM (sort ghcs) $ \ghc -> do artifacts <- forM (sort ghcs) $ \ghc -> do
let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc) let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)
@ -658,3 +705,19 @@ rmHLSVer ver = do
case headMay . reverse . sort $ hlsVers of case headMay . reverse . sort $ hlsVers of
Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing
Nothing -> pure () Nothing -> pure ()
getCabalVersion :: (MonadIO m, MonadFail m) => FilePath -> m Version
getCabalVersion fp = do
contents <- liftIO $ B.readFile fp
gpd <- case parseGenericPackageDescriptionMaybe contents of
Nothing -> fail $ "could not parse cabal file: " <> fp
Just r -> pure r
let tver = (\c -> Version Nothing c [] Nothing)
. NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)
. versionNumbers
. pkgVersion
. package
. packageDescription
$ gpd
pure tver

View File

@ -654,10 +654,3 @@ isSafeDir (IsolateDirResolved _) = False
isSafeDir (GHCupDir _) = True isSafeDir (GHCupDir _) = True
isSafeDir (GHCupBinDir _) = False isSafeDir (GHCupBinDir _) = False

View File

@ -1097,7 +1097,8 @@ runBuildAction bdir action = do
-- | Clean up the given directory if the action fails, -- | Clean up the given directory if the action fails,
-- depending on the Settings. -- depending on the Settings.
cleanUpOnError :: ( MonadReader env m cleanUpOnError :: forall e m a env .
( MonadReader env m
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadIO m , MonadIO m