Julian Ospald
7a2a5074fa
This is a major refactor of some CLI code. We try to distinguish GHC versions from other versions, so that we can use distinct parsers. Hopefully this doesn't introduce new bugs. This also forces ghcup run to use the new internal ~/.ghcup/tmp dir.
503 lines
17 KiB
Haskell
503 lines
17 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
module GHCup.OptParse.Run where
|
|
|
|
|
|
import GHCup
|
|
import GHCup.Utils
|
|
import GHCup.OptParse.Common
|
|
import GHCup.Errors
|
|
import GHCup.Types
|
|
import GHCup.Types.Optics
|
|
import GHCup.Prelude
|
|
import GHCup.Prelude.File
|
|
#ifdef IS_WINDOWS
|
|
import GHCup.Prelude.Process
|
|
import GHCup.Prelude.Process.Windows ( execNoMinGW )
|
|
#endif
|
|
import GHCup.Prelude.Logger
|
|
import GHCup.Prelude.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.FilePath
|
|
import System.Environment
|
|
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
|
|
import Data.Versions ( prettyVer, Version )
|
|
|
|
|
|
|
|
|
|
|
|
---------------
|
|
--[ Options ]--
|
|
---------------
|
|
|
|
|
|
data RunOptions = RunOptions
|
|
{ runAppendPATH :: Bool
|
|
, runInstTool' :: Bool
|
|
, runMinGWPath :: Bool
|
|
, runGHCVer :: Maybe ToolVersion
|
|
, runCabalVer :: Maybe ToolVersion
|
|
, runHLSVer :: Maybe ToolVersion
|
|
, runStackVer :: Maybe ToolVersion
|
|
, runBinDir :: Maybe FilePath
|
|
, runQuick :: Bool
|
|
, 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")
|
|
<*> switch
|
|
(short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)")
|
|
<*> optional
|
|
(option
|
|
(eitherReader ghcVersionTagEither)
|
|
(metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version"
|
|
<> completer (tagCompleter GHC [])
|
|
<> (completer $ versionCompleter Nothing GHC)
|
|
)
|
|
)
|
|
<*> optional
|
|
(option
|
|
(eitherReader toolVersionTagEither)
|
|
(metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version"
|
|
<> completer (tagCompleter Cabal [])
|
|
<> (completer $ versionCompleter Nothing Cabal)
|
|
)
|
|
)
|
|
<*> optional
|
|
(option
|
|
(eitherReader toolVersionTagEither)
|
|
(metavar "HLS_VERSION" <> long "hls" <> help "The HLS version"
|
|
<> completer (tagCompleter HLS [])
|
|
<> (completer $ versionCompleter Nothing HLS)
|
|
)
|
|
)
|
|
<*> optional
|
|
(option
|
|
(eitherReader toolVersionTagEither)
|
|
(metavar "STACK_VERSION" <> long "stack" <> help "The stack version"
|
|
<> completer (tagCompleter Stack [])
|
|
<> (completer $ versionCompleter Nothing Stack)
|
|
)
|
|
)
|
|
<*> optional
|
|
(option
|
|
(eitherReader isolateParser)
|
|
( short 'b'
|
|
<> long "bindir"
|
|
<> metavar "DIR"
|
|
<> help "directory where to create the tool symlinks (default: newly created system temp dir)"
|
|
<> completer (bashCompleter "directory")
|
|
)
|
|
)
|
|
<*> switch
|
|
(short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.")
|
|
<*> 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
|
|
, UninstallFailed
|
|
, MergeFileTreeError
|
|
]
|
|
|
|
runLeanRUN :: (MonadUnliftIO m, MonadIO m)
|
|
=> LeanAppState
|
|
-> Excepts RunEffects (ReaderT LeanAppState m) a
|
|
-> m (VEither RunEffects a)
|
|
runLeanRUN leanAppstate =
|
|
-- Don't use runLeanAppState here, which is disabled on windows.
|
|
-- This is the only command on all platforms that doesn't need full appstate.
|
|
flip runReaderT leanAppstate
|
|
. runE
|
|
@RunEffects
|
|
|
|
runRUN :: MonadUnliftIO m
|
|
=> IO AppState
|
|
-> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
|
|
-> m (VEither RunEffects a)
|
|
runRUN appState action' = do
|
|
s' <- liftIO appState
|
|
flip runReaderT s'
|
|
. runResourceT
|
|
. runE
|
|
@RunEffects
|
|
$ action'
|
|
|
|
|
|
|
|
------------------
|
|
--[ Entrypoint ]--
|
|
------------------
|
|
|
|
|
|
|
|
run :: forall m .
|
|
( MonadFail m
|
|
, MonadMask m
|
|
, MonadCatch m
|
|
, MonadIO m
|
|
, MonadUnliftIO m
|
|
)
|
|
=> RunOptions
|
|
-> IO AppState
|
|
-> LeanAppState
|
|
-> (ReaderT LeanAppState m () -> m ())
|
|
-> m ExitCode
|
|
run RunOptions{..} runAppState leanAppstate runLogger = do
|
|
r <- if not runQuick
|
|
then runRUN runAppState $ do
|
|
toolchain <- liftE resolveToolchainFull
|
|
|
|
-- oh dear
|
|
r <- lift ask
|
|
tmp <- lift . lift . lift . flip runReaderT (fromAppState r) $ createTmpDir toolchain
|
|
|
|
liftE $ installToolChainFull toolchain tmp
|
|
pure tmp
|
|
else runLeanRUN leanAppstate $ do
|
|
toolchain <- resolveToolchain
|
|
tmp <- lift $ createTmpDir toolchain
|
|
liftE $ installToolChain toolchain tmp
|
|
pure tmp
|
|
case r of
|
|
VRight tmp -> do
|
|
case runCOMMAND of
|
|
[] -> do
|
|
liftIO $ putStr tmp
|
|
pure ExitSuccess
|
|
(cmd:args) -> do
|
|
newEnv <- liftIO $ addToPath tmp
|
|
#ifndef IS_WINDOWS
|
|
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
|
|
pure ExitSuccess
|
|
#else
|
|
r' <- if runMinGWPath
|
|
then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
|
|
else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv)
|
|
case r' of
|
|
VRight _ -> pure ExitSuccess
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 28
|
|
#endif
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 27
|
|
|
|
where
|
|
|
|
-- TODO: doesn't work for cross
|
|
resolveToolchainFull :: ( MonadFail m
|
|
, MonadThrow m
|
|
, MonadIO m
|
|
, MonadCatch m
|
|
)
|
|
=> Excepts
|
|
'[ TagNotFound
|
|
, NextVerNotFound
|
|
, NoToolVersionSet
|
|
] (ResourceT (ReaderT AppState m)) Toolchain
|
|
resolveToolchainFull = do
|
|
ghcVer <- forM runGHCVer $ \ver -> do
|
|
(v, _) <- liftE $ fromVersion (Just ver) GHC
|
|
pure v
|
|
cabalVer <- forM runCabalVer $ \ver -> do
|
|
(v, _) <- liftE $ fromVersion (Just ver) Cabal
|
|
pure (_tvVersion v)
|
|
hlsVer <- forM runHLSVer $ \ver -> do
|
|
(v, _) <- liftE $ fromVersion (Just ver) HLS
|
|
pure (_tvVersion v)
|
|
stackVer <- forM runStackVer $ \ver -> do
|
|
(v, _) <- liftE $ fromVersion (Just ver) Stack
|
|
pure (_tvVersion v)
|
|
pure Toolchain{..}
|
|
|
|
resolveToolchain = do
|
|
ghcVer <- case runGHCVer of
|
|
Just (GHCVersion v) -> pure $ Just v
|
|
Just (ToolVersion v) -> pure $ Just (mkTVer v)
|
|
Nothing -> pure Nothing
|
|
_ -> fail "Internal error"
|
|
cabalVer <- case runCabalVer of
|
|
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
|
|
Just (ToolVersion v) -> pure $ Just v
|
|
Nothing -> pure Nothing
|
|
_ -> fail "Internal error"
|
|
hlsVer <- case runHLSVer of
|
|
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
|
|
Just (ToolVersion v) -> pure $ Just v
|
|
Nothing -> pure Nothing
|
|
_ -> fail "Internal error"
|
|
stackVer <- case runStackVer of
|
|
Just (GHCVersion v) -> pure $ Just (_tvVersion v)
|
|
Just (ToolVersion v) -> pure $ Just v
|
|
Nothing -> pure Nothing
|
|
_ -> fail "Internal error"
|
|
pure Toolchain{..}
|
|
|
|
installToolChainFull :: ( MonadFail m
|
|
, MonadThrow m
|
|
, MonadIO m
|
|
, MonadCatch m
|
|
)
|
|
=> Toolchain
|
|
-> FilePath
|
|
-> Excepts
|
|
'[ TagNotFound
|
|
, NextVerNotFound
|
|
, NoToolVersionSet
|
|
, UnknownArchive
|
|
, TarDirDoesNotExist
|
|
, ProcessError
|
|
, NotInstalled
|
|
, NoDownload
|
|
, GPGError
|
|
, DownloadFailed
|
|
, DirNotEmpty
|
|
, DigestError
|
|
, BuildFailed
|
|
, ArchiveResult
|
|
, AlreadyInstalled
|
|
, FileAlreadyExistsError
|
|
, CopyError
|
|
, UninstallFailed
|
|
, MergeFileTreeError
|
|
] (ResourceT (ReaderT AppState m)) ()
|
|
installToolChainFull Toolchain{..} tmp = do
|
|
case ghcVer of
|
|
Just v -> do
|
|
isInstalled <- lift $ checkIfToolInstalled' GHC v
|
|
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
|
|
(_tvVersion v)
|
|
GHCupInternal
|
|
False
|
|
[]
|
|
setGHC' v tmp
|
|
_ -> pure ()
|
|
case cabalVer of
|
|
Just v -> do
|
|
isInstalled <- lift $ checkIfToolInstalled' Cabal (mkTVer v)
|
|
unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin
|
|
v
|
|
GHCupInternal
|
|
False
|
|
setCabal' v tmp
|
|
_ -> pure ()
|
|
case stackVer of
|
|
Just v -> do
|
|
isInstalled <- lift $ checkIfToolInstalled' Stack (mkTVer v)
|
|
unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin
|
|
v
|
|
GHCupInternal
|
|
False
|
|
setStack' v tmp
|
|
_ -> pure ()
|
|
case hlsVer of
|
|
Just v -> do
|
|
isInstalled <- lift $ checkIfToolInstalled' HLS (mkTVer v)
|
|
unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin
|
|
v
|
|
GHCupInternal
|
|
False
|
|
setHLS' v tmp
|
|
_ -> pure ()
|
|
|
|
installToolChain :: ( MonadFail m
|
|
, MonadThrow m
|
|
, MonadIO m
|
|
, MonadCatch m
|
|
)
|
|
=> Toolchain
|
|
-> FilePath
|
|
-> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()
|
|
installToolChain Toolchain{..} tmp = do
|
|
case ghcVer of
|
|
Just v -> setGHC' v tmp
|
|
_ -> pure ()
|
|
case cabalVer of
|
|
Just v -> setCabal' v tmp
|
|
_ -> pure ()
|
|
case stackVer of
|
|
Just v -> setStack' v tmp
|
|
_ -> pure ()
|
|
case hlsVer of
|
|
Just v -> setHLS' v tmp
|
|
_ -> pure ()
|
|
|
|
setGHC' v tmp = do
|
|
void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)
|
|
void $ liftE $ setGHC v SetGHCOnly (Just tmp)
|
|
setCabal' v tmp = do
|
|
bin <- liftE $ whereIsTool Cabal (mkTVer v)
|
|
cbin <- liftIO $ canonicalizePath bin
|
|
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))
|
|
setStack' v tmp = do
|
|
bin <- liftE $ whereIsTool Stack (mkTVer v)
|
|
cbin <- liftIO $ canonicalizePath bin
|
|
lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))
|
|
setHLS' v tmp = do
|
|
Dirs {..} <- getDirs
|
|
legacy <- isLegacyHLS v
|
|
if legacy
|
|
then do
|
|
-- TODO: factor this out
|
|
hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? (NotInstalled HLS (mkTVer v))
|
|
cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)
|
|
lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)
|
|
hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))
|
|
forM_ hlsBins $ \bin ->
|
|
lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin)
|
|
liftE $ setHLS v SetHLSOnly (Just tmp)
|
|
else do
|
|
liftE $ setHLS v SetHLS_XYZ (Just tmp)
|
|
liftE $ setHLS v SetHLSOnly (Just tmp)
|
|
|
|
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
|
|
|
|
createTmpDir :: ( MonadUnliftIO m
|
|
, MonadCatch m
|
|
, MonadThrow m
|
|
, MonadMask m
|
|
, MonadIO m
|
|
)
|
|
=> Toolchain
|
|
-> ReaderT LeanAppState m FilePath
|
|
createTmpDir toolchain =
|
|
case runBinDir of
|
|
Just bindir -> do
|
|
liftIO $ createDirRecursive' bindir
|
|
liftIO $ canonicalizePath bindir
|
|
Nothing -> do
|
|
d <- predictableTmpDir toolchain
|
|
liftIO $ createDirRecursive' d
|
|
liftIO $ canonicalizePath d
|
|
|
|
predictableTmpDir :: Monad m
|
|
=> Toolchain
|
|
-> ReaderT LeanAppState m FilePath
|
|
predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) = do
|
|
Dirs { tmpDir } <- getDirs
|
|
pure (fromGHCupPath tmpDir </> "ghcup-none")
|
|
predictableTmpDir Toolchain{..} = do
|
|
Dirs { tmpDir } <- getDirs
|
|
pure $ fromGHCupPath tmpDir
|
|
</> ("ghcup-" <> intercalate "_"
|
|
( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer
|
|
<> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . prettyVer) cabalVer
|
|
<> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . prettyVer) hlsVer
|
|
<> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . prettyVer) stackVer
|
|
)
|
|
)
|
|
|
|
|
|
|
|
-------------------------
|
|
--[ Other local types ]--
|
|
-------------------------
|
|
|
|
|
|
|
|
data Toolchain = Toolchain
|
|
{ ghcVer :: Maybe GHCTargetVersion
|
|
, cabalVer :: Maybe Version
|
|
, hlsVer :: Maybe Version
|
|
, stackVer :: Maybe Version
|
|
} deriving Show
|