From c72841ca5886071dd9cbdba708d7dab70baaf27d Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 9 Feb 2022 18:57:59 +0100 Subject: [PATCH] Implement 'ghcup run' --- app/ghcup/BrickMain.hs | 4 +- app/ghcup/GHCup/OptParse.hs | 13 ++ app/ghcup/GHCup/OptParse/Compile.hs | 4 +- app/ghcup/GHCup/OptParse/Install.hs | 4 +- app/ghcup/GHCup/OptParse/Run.hs | 268 ++++++++++++++++++++++++++++ app/ghcup/GHCup/OptParse/Set.hs | 8 +- app/ghcup/Main.hs | 1 + ghcup.cabal | 2 + lib/GHCup.hs | 86 +++++---- lib/GHCup/Utils.hs | 10 +- 10 files changed, 353 insertions(+), 47 deletions(-) create mode 100644 app/ghcup/GHCup/OptParse/Run.hs 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..1b5b05d --- /dev/null +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -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 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..e3836d3 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 runLogger case res of ExitSuccess -> pure () diff --git a/ghcup.cabal b/ghcup.cabal index 18c9b8b..46cb67d 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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index ce3e61e..da8fed8 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 (mBinDir == Nothing) $ + 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 (mBinDir == Nothing) $ 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 (mBinDir == Nothing) $ + 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 (mBinDir == Nothing) $ + 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')