{-# 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