hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement 'ghcup run'

This commit is contained in:
Julian Ospald 2022-02-09 18:57:59 +01:00
parent 63350dab71
commit c72841ca58
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
10 changed files with 353 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
app/ghcup/BrickMain.hs
View File

@ -493,9 +493,9 @@ set' _ (_, ListResult {..}) = do
run (do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> ()
Cabal -> liftE $ setCabal lVer $> ()
HLS -> liftE $ setHLS lVer SetHLSOnly $> ()
HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
Stack -> liftE $ setStack lVer $> ()
GHCup -> pure ()
)

13
app/ghcup/GHCup/OptParse.hs
View File

@ -24,6 +24,7 @@ module GHCup.OptParse (
, module GHCup.OptParse.DInfo
, module GHCup.OptParse.Nuke
, module GHCup.OptParse.ToolRequirements
, module GHCup.OptParse.Run
, module GHCup.OptParse
) where
@ -33,6 +34,7 @@ import GHCup.OptParse.Install
import GHCup.OptParse.Set
import GHCup.OptParse.UnSet
import GHCup.OptParse.Rm
import GHCup.OptParse.Run
import GHCup.OptParse.Compile
import GHCup.OptParse.Config
import GHCup.OptParse.Whereis
@ -104,6 +106,7 @@ data Command
#endif
| Prefetch PrefetchCommand
| GC GCOptions
| Run RunOptions
@ -263,6 +266,16 @@ com =
(progDesc "Garbage collection"
<> footerDoc ( Just $ text gcFooter ))
)
<> command
"run"
(Run
<$>
info
(runOpts <**> helper)
(progDesc "Run a command with the given tool in PATH"
<> footerDoc ( Just $ text runFooter )
)
)
<> commandGroup "Main commands:"
)
<|> subparser

4
app/ghcup/GHCup/OptParse/Compile.hs
View File

@ -466,7 +466,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
when setCompile $ void $ liftE $
setHLS targetVer SetHLSOnly
setHLS targetVer SetHLSOnly Nothing
pure (vi, targetVer)
)
>>= \case
@ -517,7 +517,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls
when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly
setGHC targetVer SetGHCOnly Nothing
pure (vi, targetVer)
)
>>= \case

4
app/ghcup/GHCup/OptParse/Install.hs
View File

@ -352,7 +352,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
isolateDir
forceInstall
)
$ when instSet $ void $ setGHC v SetGHCOnly
$ when instSet $ void $ setGHC v SetGHCOnly Nothing
pure vi
Just uri -> do
runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
@ -363,7 +363,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
isolateDir
forceInstall
)
$ when instSet $ void $ setGHC v SetGHCOnly
$ when instSet $ void $ setGHC v SetGHCOnly Nothing
pure vi
)
>>= \case

268
app/ghcup/GHCup/OptParse/Run.hs Normal file
View File

@ -0,0 +1,268 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.OptParse.Run where
import GHCup
import GHCup.Utils
import GHCup.Utils.Prelude
import GHCup.Utils.File
import GHCup.OptParse.Common
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
import Control.Exception.Safe ( MonadMask, MonadCatch )
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Codec.Archive
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe (isNothing)
import Data.List ( intercalate )
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Directory
import System.FilePath
import System.Environment
import System.IO.Temp
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
#ifndef IS_WINDOWS
import qualified System.Posix.Process as SPP
#endif
---------------
--[ Options ]--
---------------
data RunOptions = RunOptions
{ runAppendPATH :: Bool
, runInstTool' :: Bool
, runGHCVer :: Maybe ToolVersion
, runCabalVer :: Maybe ToolVersion
, runHLSVer :: Maybe ToolVersion
, runStackVer :: Maybe ToolVersion
, runBinDir :: Maybe FilePath
, runCOMMAND :: [String]
}
---------------
--[ Parsers ]--
---------------
runOpts :: Parser RunOptions
runOpts =
RunOptions
<$> switch
(short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)")
<*> switch
(short 'i' <> long "install" <> help "Install the tool, if missing")
<*> optional
(option
(eitherReader toolVersionEither)
(metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version")
)
<*> optional
(option
(eitherReader toolVersionEither)
(metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version")
)
<*> optional
(option
(eitherReader toolVersionEither)
(metavar "HLS_VERSION" <> long "hls" <> help "The HLS version")
)
<*> optional
(option
(eitherReader toolVersionEither)
(metavar "STACK_VERSION" <> long "stack" <> help "The stack version")
)
<*> optional
(option
(eitherReader isolateParser)
( short 'b'
<> long "bindir"
<> metavar "DIR"
<> help "directory where to create the tool symlinks (default: newly created system temp dir)"
)
)
<*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))
--------------
--[ Footer ]--
--------------
runFooter :: String
runFooter = [s|Discussion:
Adds the given tools to a dedicated bin/ directory and adds them to PATH, exposing
the relevant binaries, then executes a command.
Examples:
# run VSCode with all latest toolchain exposed, installing missing versions if necessary
ghcup run --ghc latest --cabal latest --hls latest --stack latest --install -- code Setup.hs
# create a custom toolchain bin/ dir with GHC and cabal that can be manually added to PATH
ghcup run --ghc 8.10.7 --cabal 3.2.0.0 --bindir $HOME/toolchain/bin
# run a specific ghc version
ghcup run --ghc 8.10.7 -- ghc --version|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type RunEffects = '[ AlreadyInstalled
, UnknownArchive
, ArchiveResult
, FileDoesNotExistError
, CopyError
, NotInstalled
, DirNotEmpty
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, GPGError
, DownloadFailed
, TarDirDoesNotExist
, NextVerNotFound
, NoToolVersionSet
, FileAlreadyExistsError
, ProcessError
]
runRUN :: MonadUnliftIO m
=> (ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))
-> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
-> m (VEither RunEffects a)
runRUN runAppState =
runAppState
. runResourceT
. runE
@RunEffects
------------------
--[ Entrypoint ]--
------------------
run :: forall m.
( MonadFail m
, MonadMask m
, MonadCatch m
, MonadIO m
, MonadUnliftIO m
)
=> RunOptions
-> (forall a. ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
run RunOptions{..} runAppState runLogger = runRUN runAppState (do
tmp <- case runBinDir of
Just bdir -> do
liftIO $ createDirRecursive' bdir
liftIO $ canonicalizePath bdir
Nothing -> liftIO (getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "ghcup")
forM_ runGHCVer $ addToolToDir tmp GHC
forM_ runCabalVer $ addToolToDir tmp Cabal
forM_ runHLSVer $ addToolToDir tmp HLS
forM_ runStackVer $ addToolToDir tmp Stack
case runCOMMAND of
[] -> liftIO $ putStr tmp
(cmd:args) -> do
newEnv <- liftIO $ addToPath tmp
if isWindows
then liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
else liftIO $ SPP.executeFile cmd True args (Just newEnv)
pure ()
) >>= \case
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 27
where
-- TODO: doesn't work for cross
addToolToDir tmp tool ver = do
(v, _) <- liftE $ fromVersion (Just ver) tool
isInstalled <- checkIfToolInstalled' tool v
case tool of
GHC -> do
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
(_tvVersion v)
Nothing
False
void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)
void $ liftE $ setGHC v SetGHCOnly (Just tmp)
pure ()
Cabal -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
(_tvVersion v)
Nothing
False
bin <- liftE $ whereIsTool Cabal v
cbin <- liftIO $ canonicalizePath bin
lift $ createLink (relativeSymlink tmp cbin) (tmp </> "cabal")
pure ()
Stack -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
(_tvVersion v)
Nothing
False
bin <- liftE $ whereIsTool Stack v
cbin <- liftIO $ canonicalizePath bin
lift $ createLink (relativeSymlink tmp cbin) (tmp </> "stack")
pure ()
HLS -> do
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
(_tvVersion v)
Nothing
False
liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp)
liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)
pure ()
GHCup -> pure ()
addToPath path = do
cEnv <- Map.fromList <$> getEnvironment
let paths = ["PATH", "Path"]
curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
newPath = intercalate [searchPathSeparator] (if runAppendPATH then (curPaths ++ [path]) else (path : curPaths))
envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
pathVar = if isWindows then "Path" else "PATH"
envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath
liftIO $ setEnv pathVar newPath
return envWithNewPath

8
app/ghcup/GHCup/OptParse/Set.hs
View File

@ -271,10 +271,10 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode
setGHC' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly >> pure v)
(SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v)
_ -> runSetGHC runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer GHC
liftE $ setGHC v SetGHCOnly
liftE $ setGHC v SetGHCOnly Nothing
)
>>= \case
VRight GHCTargetVersion{..} -> do
@ -311,10 +311,10 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode
setHLS' SetOptions{ sToolVer } =
case sToolVer of
(SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly >> pure v)
(SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing >> pure v)
_ -> runSetHLS runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS
liftE $ setHLS (_tvVersion v) SetHLSOnly
liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing
pure v
)
>>= \case

1
app/ghcup/Main.hs
View File

@ -313,6 +313,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nuke -> nuke appState runLogger
Prefetch pfCom -> prefetch pfCom runAppState runLogger
GC gcOpts -> gc gcOpts runAppState runLogger
Run runCommand -> run runCommand runAppState runLogger
case res of
ExitSuccess -> pure ()

2
ghcup.cabal
View File

@ -200,6 +200,7 @@ executable ghcup
GHCup.OptParse.Nuke
GHCup.OptParse.Prefetch
GHCup.OptParse.Rm
GHCup.OptParse.Run
GHCup.OptParse.Set
GHCup.OptParse.ToolRequirements
GHCup.OptParse.UnSet
@ -243,6 +244,7 @@ executable ghcup
, resourcet ^>=1.2.2
, safe ^>=0.3.18
, safe-exceptions ^>=0.1
, temporary ^>=1.3
, template-haskell >=2.7 && <2.18
, text ^>=1.2.4.0
, uri-bytestring ^>=0.3.2.2

86
lib/GHCup.hs
View File

@ -624,7 +624,7 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
else do
inst <- ghcupHLSDir ver
liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir inst ver
liftE $ setHLS ver SetHLS_XYZ
liftE $ setHLS ver SetHLS_XYZ Nothing
liftE $ installHLSPostInst isoFilepath ver
@ -707,7 +707,7 @@ installHLSPostInst isoFilepath ver =
-- create symlink if this is the latest version in a regular install
hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver SetHLSOnly
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver SetHLSOnly Nothing
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
@ -1092,22 +1092,29 @@ setGHC :: ( MonadReader env m
)
=> GHCTargetVersion
-> SetGHC
-> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin
-- and don't want mess with other versions
-> Excepts '[NotInstalled] m GHCTargetVersion
setGHC ver sghc = do
setGHC ver sghc mBinDir = do
let verS = T.unpack $ prettyVer (_tvVersion ver)
ghcdir <- lift $ ghcupGHCDir ver
whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
-- symlink destination
Dirs {..} <- lift getDirs
binDir <- case mBinDir of
Just x -> pure x
Nothing -> do
Dirs {binDir = f} <- lift getDirs
pure f
-- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
case sghc of
SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver)
SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver
SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver
when (mBinDir == Nothing) $
case sghc of
SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver)
SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver
SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver
@ -1129,13 +1136,14 @@ setGHC ver sghc = do
bindir <- ghcInternalBinDir ver
let fullF = binDir </> targetFile <> exeExt
fileWithExt = bindir </> file <> exeExt
destL <- binarySymLinkDestination fileWithExt
destL <- binarySymLinkDestination binDir fileWithExt
lift $ createLink destL fullF
-- create symlink for share dir
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
when (mBinDir == Nothing) $ do
-- create symlink for share dir
when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility
when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility
pure ver
@ -1241,19 +1249,26 @@ setHLS :: ( MonadReader env m
)
=> Version
-> SetHLS -- Nothing for legacy
-> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin
-- and don't want mess with other versions
-> Excepts '[NotInstalled] m ()
setHLS ver shls = do
setHLS ver shls mBinDir = do
whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)))
-- symlink destination
Dirs {..} <- lift getDirs
binDir <- case mBinDir of
Just x -> pure x
Nothing -> do
Dirs {binDir = f} <- lift getDirs
pure f
-- first delete the old symlinks
case shls of
-- not for legacy
SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver
-- legacy and new
SetHLSOnly -> liftE rmPlainHLS
when (mBinDir == Nothing) $
case shls of
-- not for legacy
SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver
-- legacy and new
SetHLSOnly -> liftE rmPlainHLS
case shls of
-- not for legacy
@ -1262,7 +1277,7 @@ setHLS ver shls = do
forM_ bins $ \f -> do
let fname = takeFileName f
destL <- binarySymLinkDestination f
destL <- binarySymLinkDestination binDir f
let target = if "haskell-language-server-wrapper" `isPrefixOf` fname
then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt
else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt
@ -1285,7 +1300,8 @@ setHLS ver shls = do
lift $ createLink destL wrapper
lift warnAboutHlsCompatibility
when (mBinDir == Nothing) $
lift warnAboutHlsCompatibility
unsetHLS :: ( MonadMask m
@ -1774,7 +1790,7 @@ rmGHCVer ver = do
$ fmap Just
$ getMajorMinorV (_tvVersion ver)
forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver))
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing)
Dirs {..} <- lift getDirs
@ -1841,7 +1857,7 @@ rmHLSVer ver = do
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
Just latestver -> setHLS latestver SetHLSOnly
Just latestver -> setHLS latestver SetHLSOnly Nothing
Nothing -> pure ()
@ -2275,7 +2291,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr
Nothing -> do
reThrowAll GHCupSetError $ postGHCInstall installVer
-- restore
when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly
when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing
_ -> pure ()
@ -2669,7 +2685,7 @@ postGHCInstall :: ( MonadReader env m
=> GHCTargetVersion
-> Excepts '[NotInstalled] m ()
postGHCInstall ver@GHCTargetVersion {..} = do
void $ liftE $ setGHC ver SetGHC_XYZ
void $ liftE $ setGHC ver SetGHC_XYZ Nothing
-- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless.
@ -2678,7 +2694,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
$ fmap Just
$ getMajorMinorV _tvVersion
forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget)
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
>>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing)
-- | Reports the binary location of a given tool:
@ -2739,13 +2755,21 @@ checkIfToolInstalled :: ( MonadIO m
Tool ->
Version ->
m Bool
checkIfToolInstalled tool ver = checkIfToolInstalled' tool (mkTVer ver)
checkIfToolInstalled tool ver =
checkIfToolInstalled' :: ( MonadIO m
, MonadReader env m
, HasDirs env
, MonadCatch m) =>
Tool ->
GHCTargetVersion ->
m Bool
checkIfToolInstalled' tool ver =
case tool of
Cabal -> cabalInstalled ver
HLS -> hlsInstalled ver
Stack -> stackInstalled ver
GHC -> ghcInstalled $ mkTVer ver
Cabal -> cabalInstalled (_tvVersion ver)
HLS -> hlsInstalled (_tvVersion ver)
Stack -> stackInstalled (_tvVersion ver)
GHC -> ghcInstalled ver
_ -> pure False
throwIfFileAlreadyExists :: ( MonadIO m ) =>

10
lib/GHCup/Utils.hs
View File

@ -126,15 +126,13 @@ import qualified Data.List.NonEmpty as NE
-- | Create a relative symlink destination for the binary directory,
-- given a target toolpath.
binarySymLinkDestination :: ( MonadReader env m
, HasDirs env
, MonadThrow m
binarySymLinkDestination :: ( MonadThrow m
, MonadIO m
)
=> FilePath -- ^ the full toolpath
=> FilePath -- ^ binary dir
-> FilePath -- ^ the full toolpath
-> m FilePath
binarySymLinkDestination toolPath = do
Dirs {..} <- getDirs
binarySymLinkDestination binDir toolPath = do
toolPath' <- liftIO $ canonicalizePath toolPath
binDir' <- liftIO $ canonicalizePath binDir
pure (relativeSymlink binDir' toolPath')