diff --git a/.gitlab/ghcup-run.files b/.gitlab/ghcup-run.files new file mode 100644 index 0000000..144914a --- /dev/null +++ b/.gitlab/ghcup-run.files @@ -0,0 +1,37 @@ +. +./cabal +./ghc +./ghc-8.10.7 +./ghc-pkg +./ghc-pkg-8.10.7 +./ghci +./ghci-8.10.7 +./haddock +./haddock-8.10.7 +./haskell-language-server-8.10.6 +./haskell-language-server-8.10.6~1.6.1.0 +./haskell-language-server-8.10.7 +./haskell-language-server-8.10.7~1.6.1.0 +./haskell-language-server-8.6.5 +./haskell-language-server-8.6.5~1.6.1.0 +./haskell-language-server-8.8.4 +./haskell-language-server-8.8.4~1.6.1.0 +./haskell-language-server-9.0.1 +./haskell-language-server-9.0.1~1.6.1.0 +./haskell-language-server-9.0.2 +./haskell-language-server-9.0.2~1.6.1.0 +./haskell-language-server-9.2.1 +./haskell-language-server-9.2.1~1.6.1.0 +./haskell-language-server-wrapper +./haskell-language-server-wrapper-1.6.1.0 +./hp2ps +./hp2ps-8.10.7 +./hpc +./hpc-8.10.7 +./hsc2hs +./hsc2hs-8.10.7 +./runghc +./runghc-8.10.7 +./runhaskell +./runhaskell-8.10.7 +./stack diff --git a/.gitlab/ghcup-run.files.windows b/.gitlab/ghcup-run.files.windows new file mode 100644 index 0000000..8c5d628 --- /dev/null +++ b/.gitlab/ghcup-run.files.windows @@ -0,0 +1,81 @@ +. +./cabal.exe +./cabal.shim +./ghc-8.10.7.exe +./ghc-8.10.7.shim +./ghc-pkg-8.10.7.exe +./ghc-pkg-8.10.7.shim +./ghc-pkg.exe +./ghc-pkg.shim +./ghc.exe +./ghc.shim +./ghci-8.10.7.exe +./ghci-8.10.7.shim +./ghci.exe +./ghci.shim +./ghcii-8.10.7.sh-8.10.7.exe +./ghcii-8.10.7.sh-8.10.7.shim +./ghcii-8.10.7.sh.exe +./ghcii-8.10.7.sh.shim +./ghcii.sh-8.10.7.exe +./ghcii.sh-8.10.7.shim +./ghcii.sh.exe +./ghcii.sh.shim +./haddock-8.10.7.exe +./haddock-8.10.7.shim +./haddock.exe +./haddock.shim +./haskell-language-server-8.10.6.exe +./haskell-language-server-8.10.6.shim +./haskell-language-server-8.10.6~1.6.1.0.exe +./haskell-language-server-8.10.6~1.6.1.0.shim +./haskell-language-server-8.10.7.exe +./haskell-language-server-8.10.7.shim +./haskell-language-server-8.10.7~1.6.1.0.exe +./haskell-language-server-8.10.7~1.6.1.0.shim +./haskell-language-server-8.6.5.exe +./haskell-language-server-8.6.5.shim +./haskell-language-server-8.6.5~1.6.1.0.exe +./haskell-language-server-8.6.5~1.6.1.0.shim +./haskell-language-server-8.8.4.exe +./haskell-language-server-8.8.4.shim +./haskell-language-server-8.8.4~1.6.1.0.exe +./haskell-language-server-8.8.4~1.6.1.0.shim +./haskell-language-server-9.0.1.exe +./haskell-language-server-9.0.1.shim +./haskell-language-server-9.0.1~1.6.1.0.exe +./haskell-language-server-9.0.1~1.6.1.0.shim +./haskell-language-server-9.0.2.exe +./haskell-language-server-9.0.2.shim +./haskell-language-server-9.0.2~1.6.1.0.exe +./haskell-language-server-9.0.2~1.6.1.0.shim +./haskell-language-server-9.2.1.exe +./haskell-language-server-9.2.1.shim +./haskell-language-server-9.2.1~1.6.1.0.exe +./haskell-language-server-9.2.1~1.6.1.0.shim +./haskell-language-server-wrapper-1.6.1.0.exe +./haskell-language-server-wrapper-1.6.1.0.shim +./haskell-language-server-wrapper.exe +./haskell-language-server-wrapper.shim +./hp2ps-8.10.7.exe +./hp2ps-8.10.7.shim +./hp2ps.exe +./hp2ps.shim +./hpc-8.10.7.exe +./hpc-8.10.7.shim +./hpc.exe +./hpc.shim +./hsc2hs-8.10.7.exe +./hsc2hs-8.10.7.shim +./hsc2hs.exe +./hsc2hs.shim +./runghc-8.10.7.exe +./runghc-8.10.7.shim +./runghc.exe +./runghc.shim +./runhaskell-8.10.7.exe +./runhaskell-8.10.7.shim +./runhaskell.exe +./runhaskell.shim +./stack.exe +./stack.shim diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index bf5f6c4..3cdab04 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -97,6 +97,7 @@ eghcup --numeric-version eghcup install ghc ${GHC_VERSION} [ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ] +[ `eghcup run --ghc ${GHC_VERSION} -- ghc --numeric-version` = "${GHC_VERSION}" ] eghcup set ghc ${GHC_VERSION} eghcup install cabal ${CABAL_VERSION} [ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] @@ -104,6 +105,22 @@ eghcup unset cabal "$GHCUP_BIN"/cabal --version && exit || echo yes eghcup set cabal ${CABAL_VERSION} [ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] +[ `eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version` = "${CABAL_VERSION}" ] + +if [ "${OS}" != "FREEBSD" ] ; then + if [ "${ARCH}" = "64" ] ; then + eghcup run --ghc 8.10.7 --cabal 3.4.1.0 --hls 1.6.1.0 --stack 2.7.3 --install --bindir "$(pwd)/.bin" + if [ "${OS}" == "WINDOWS" ] ; then + expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files.windows" | sort) + else + expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files" | sort) + fi + actual=$(cd ".bin" && find . | sort) + [ "${actual}" = "${expected}" ] + unset actual expected + rm -rf .bin + fi +fi cabal --version @@ -133,7 +150,7 @@ else eghcup --offline install ghc 8.10.3 if [ "${ARCH}" = "64" ] ; then expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-linux.files" | sort) - actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find | sort) + actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find . | sort) [ "${actual}" = "${expected}" ] unset actual expected fi @@ -141,7 +158,7 @@ else eghcup prefetch ghc 8.10.3 eghcup --offline install ghc 8.10.3 expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-windows.files" | sort) - actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find | sort) + actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find . | sort) [ "${actual}" = "${expected}" ] unset actual expected else @@ -182,6 +199,8 @@ else fi fi + + # check that lazy loading works for 'whereis' cp "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml.bak" echo '**' > "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml" diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 8e07456..fe2bf2a 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -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 () ) diff --git a/app/ghcup/GHCup/OptParse.hs b/app/ghcup/GHCup/OptParse.hs index 120c713..89ae3b5 100644 --- a/app/ghcup/GHCup/OptParse.hs +++ b/app/ghcup/GHCup/OptParse.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index a79ef47..b9cdee9 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 03921f6..6f5f254 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -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 diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs new file mode 100644 index 0000000..b042930 --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -0,0 +1,348 @@ +{-# 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.Types.Optics ( getDirs ) +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 + ] + +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 + => (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)) + -> LeanAppState + -> (ReaderT LeanAppState m () -> m ()) + -> m ExitCode +run RunOptions{..} runAppState leanAppstate runLogger = do + tmp <- case runBinDir of + Just bdir -> do + liftIO $ createDirRecursive' bdir + liftIO $ canonicalizePath bdir + Nothing -> liftIO (getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "ghcup") + r <- do + addToolsToDir tmp + case r of + VRight _ -> 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' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec 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 + isToolTag :: ToolVersion -> Bool + isToolTag (ToolTag _) = True + isToolTag _ = False + + -- TODO: doesn't work for cross + addToolsToDir tmp + | or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do + forM_ runGHCVer $ \ver -> do + (v, _) <- liftE $ fromVersion (Just ver) GHC + installTool GHC v + setTool GHC v tmp + forM_ runCabalVer $ \ver -> do + (v, _) <- liftE $ fromVersion (Just ver) Cabal + installTool Cabal v + setTool Cabal v tmp + forM_ runHLSVer $ \ver -> do + (v, _) <- liftE $ fromVersion (Just ver) HLS + installTool HLS v + setTool HLS v tmp + forM_ runStackVer $ \ver -> do + (v, _) <- liftE $ fromVersion (Just ver) Stack + installTool Stack v + setTool Stack v tmp + | otherwise = runLeanRUN leanAppstate $ do + case runGHCVer of + Just (ToolVersion v) -> + setTool GHC v tmp + Nothing -> pure () + _ -> fail "Internal error" + case runCabalVer of + Just (ToolVersion v) -> + setTool Cabal v tmp + Nothing -> pure () + _ -> fail "Internal error" + case runHLSVer of + Just (ToolVersion v) -> + setTool HLS v tmp + Nothing -> pure () + _ -> fail "Internal error" + case runStackVer of + Just (ToolVersion v) -> + setTool Stack v tmp + Nothing -> pure () + _ -> fail "Internal error" + + installTool tool v = do + isInstalled <- checkIfToolInstalled' tool v + case tool of + GHC -> do + unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin + (_tvVersion v) + Nothing + False + Cabal -> do + unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin + (_tvVersion v) + Nothing + False + Stack -> do + unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin + (_tvVersion v) + Nothing + False + HLS -> do + unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin + (_tvVersion v) + Nothing + False + GHCup -> pure () + + setTool tool v tmp = + case tool of + GHC -> do + void $ liftE $ setGHC v SetGHC_XYZ (Just tmp) + void $ liftE $ setGHC v SetGHCOnly (Just tmp) + Cabal -> do + bin <- liftE $ whereIsTool Cabal v + cbin <- liftIO $ canonicalizePath bin + lift $ createLink (relativeSymlink tmp cbin) (tmp ("cabal" <.> exeExt)) + Stack -> do + bin <- liftE $ whereIsTool Stack v + cbin <- liftIO $ canonicalizePath bin + lift $ createLink (relativeSymlink tmp cbin) (tmp ("stack" <.> exeExt)) + HLS -> do + Dirs {..} <- getDirs + let v' = _tvVersion v + legacy <- isLegacyHLS v' + if legacy + then do + -- TODO: factor this out + (Just hlsWrapper) <- hlsWrapperBinary 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 (_tvVersion v) SetHLSOnly (Just tmp) + else do + liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp) + liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp) + 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 diff --git a/app/ghcup/GHCup/OptParse/Set.hs b/app/ghcup/GHCup/OptParse/Set.hs index a1f7b94..5514085 100644 --- a/app/ghcup/GHCup/OptParse/Set.hs +++ b/app/ghcup/GHCup/OptParse/Set.hs @@ -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 diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index f937aaa..a09f6cc 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -313,6 +313,7 @@ Report bugs at |] Nuke -> nuke appState runLogger Prefetch pfCom -> prefetch pfCom runAppState runLogger GC gcOpts -> gc gcOpts runAppState runLogger + Run runCommand -> run runCommand runAppState leanAppstate runLogger case res of ExitSuccess -> pure () diff --git a/ghcup.cabal b/ghcup.cabal index 18c9b8b..fb75a02 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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 @@ -265,6 +267,9 @@ executable ghcup if os(windows) cpp-options: -DIS_WINDOWS + else + build-depends: + , unix ^>=2.7 if flag(no-exe) buildable: False diff --git a/lib/GHCup.hs b/lib/GHCup.hs index ce3e61e..49bd93a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -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-\@ @@ -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 (isNothing mBinDir) $ + 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 (isNothing mBinDir) $ 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 (isNothing mBinDir) $ + 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 (isNothing mBinDir) $ + 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 ) => diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 485d1dc..b64117f 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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') diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs index a3ff8a2..4818fa9 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Utils/File/Common.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} module GHCup.Utils.File.Common ( module GHCup.Utils.File.Common