diff --git a/.gitlab/ghcup-run.files b/.gitlab/ghcup-run.files
new file mode 100644
index 0000000000000000000000000000000000000000..144914af73fdee0449a9ee3a92b5cfd4bd7a0c04
--- /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 0000000000000000000000000000000000000000..8c5d6288931220c028c36b085e8f121960a80513
--- /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 bf5f6c492285ffd82f05bd5a1bea8bd5129b8ac7..3cdab04421ef2ca4a57c9b2ff5185db846a8543c 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 8e07456cf7137e9ce87b2f9863c3aca80c933878..fe2bf2aa78b8ee75085c6f7b27d2693a98d3e352 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 120c713a035e23472508b4f734aac1fceefb3ec8..89ae3b55dec36087cae5795f9fc1e07975bdccb8 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 a79ef47d747dd7ca6277278168ce0b61be8faa5c..b9cdee9912c1643ac07be80ed9dc254ce952f8b3 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 03921f652ff2f31b03c099d53d53a0ec6153eb94..6f5f2542244f3b269b9112d037ffaccb1c20f859 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 0000000000000000000000000000000000000000..b0429303e3d8a370b59b0768ce13486bc94d7bca
--- /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 a1f7b9403e9c8e1f126c15f5489462eae1b39492..5514085727e8cd0b149c99173bc5fa8bbf0f33e1 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 f937aaa4f806a7af89129ecf9c86ddb89518f1dc..a09f6ccbf35a0348e5d2974ab977626bbb9ce1d1 100644
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@@ -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 leanAppstate runLogger
case res of
ExitSuccess -> pure ()
diff --git a/ghcup.cabal b/ghcup.cabal
index 18c9b8b7a6d8b8fccb2e811accaf1b651863e9a7..fb75a02f02a69125c0c5b7633a47ecf4f0df4ab1 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 ce3e61e574da5bbfce4240ea4c112dbd43a9dc85..49bd93a4b078e035a1d18450282e40fb9904f08e 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-\<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 (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 485d1dc9198784d3c9d4a793d4216ed933250c63..b64117f5802a1684c695ebd73ba73f4c4427ab41 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 a3ff8a22376f120300f4018160224ff4273c3fb7..4818fa987be5415ee0f86561433f9cc7216edfb5 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