Implement 'ghcup run'
This commit is contained in:
@@ -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 ()
|
||||
)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
268
app/ghcup/GHCup/OptParse/Run.hs
Normal 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
|
||||
@@ -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
|
||||
|
||||
@@ -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 ()
|
||||
|
||||
Reference in New Issue
Block a user