From c72841ca5886071dd9cbdba708d7dab70baaf27d Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 9 Feb 2022 18:57:59 +0100 Subject: [PATCH 1/8] 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') From 191f49adfc67ec4e54113ab6d3034182ad5081f5 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 10 Feb 2022 18:31:38 +0100 Subject: [PATCH 2/8] Add 'ghcup run' test --- .gitlab/script/ghcup_version.sh | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index bf5f6c4..e005d40 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,14 @@ 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}" ] + +eghcup run --ghc 8.10.7 --cabal 3.4.0.0 --hls 1.6.1.0 --stack 2.7.3 --install --bindir "$(pwd)/.bin" +expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files" | sort) +actual=$(cd ".bin" && find | sort) +[ "${actual}" = "${expected}" ] +unset actual expected +rm -rf .bin cabal --version @@ -182,6 +191,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" From 09a8a0bda04d43260c70ac7b2a869ae64a14e751 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 10 Feb 2022 18:35:25 +0100 Subject: [PATCH 3/8] Fix build on windows and stack --- app/ghcup/GHCup/OptParse/Run.hs | 8 +++++--- ghcup.cabal | 3 +++ 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 1b5b05d..8321fac 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -205,9 +205,11 @@ run RunOptions{..} runAppState runLogger = runRUN runAppState (do [] -> 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) +#ifndef IS_WINDOWS + liftIO $ SPP.executeFile cmd True args (Just newEnv) +#else + liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv) +#endif pure () ) >>= \case VRight _ -> do diff --git a/ghcup.cabal b/ghcup.cabal index 46cb67d..fb75a02 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -267,6 +267,9 @@ executable ghcup if os(windows) cpp-options: -DIS_WINDOWS + else + build-depends: + , unix ^>=2.7 if flag(no-exe) buildable: False From 5186d959bc79c90cf10ff873a70bf388a035ae63 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 10 Feb 2022 19:29:32 +0100 Subject: [PATCH 4/8] Avoid metadata download when possible --- app/ghcup/GHCup/OptParse/Run.hs | 171 +++++++++++++++++++++----------- app/ghcup/Main.hs | 2 +- 2 files changed, 114 insertions(+), 59 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 8321fac..2518e32 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -161,6 +161,16 @@ type RunEffects = '[ AlreadyInstalled , 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)) @@ -189,75 +199,120 @@ run :: forall m. ) => RunOptions -> (forall a. ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a)) + -> LeanAppState -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode -run RunOptions{..} runAppState runLogger = runRUN runAppState (do - tmp <- case runBinDir of +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") - 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 + r <- addToolsToDir tmp + case r of + VRight _ -> do + case runCOMMAND of + [] -> liftIO $ putStr tmp + (cmd:args) -> do + newEnv <- liftIO $ addToPath tmp #ifndef IS_WINDOWS - liftIO $ SPP.executeFile cmd True args (Just newEnv) + liftIO $ SPP.executeFile cmd True args (Just newEnv) #else - liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv) + liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv) #endif - pure () - ) >>= \case - VRight _ -> do - pure ExitSuccess - VLeft e -> do - runLogger $ logError $ T.pack $ prettyShow e - pure $ ExitFailure 27 + pure ExitSuccess + 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 - 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 () + 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") + Stack -> do + bin <- liftE $ whereIsTool Stack v + cbin <- liftIO $ canonicalizePath bin + lift $ createLink (relativeSymlink tmp cbin) (tmp "stack") + HLS -> 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"] diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index e3836d3..a09f6cc 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -313,7 +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 + Run runCommand -> run runCommand runAppState leanAppstate runLogger case res of ExitSuccess -> pure () From 66a62c170c88e1ce007faff287b18b9fba09b372 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 10 Feb 2022 20:35:09 +0100 Subject: [PATCH 5/8] Fix 'ghcup run' for legacy HLS --- app/ghcup/GHCup/OptParse/Run.hs | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 2518e32..4433a89 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -15,6 +15,7 @@ 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 @@ -309,8 +310,22 @@ run RunOptions{..} runAppState leanAppstate runLogger = do cbin <- liftIO $ canonicalizePath bin lift $ createLink (relativeSymlink tmp cbin) (tmp "stack") HLS -> do - liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp) - liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp) + 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 From 9faf17634b5adfcbea9f753361a6651aef19db94 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 10 Feb 2022 21:49:19 +0100 Subject: [PATCH 6/8] Fix hlint and windows build --- .gitlab/ghcup-run.files | 37 +++++++++++++++ .gitlab/ghcup-run.files.windows | 81 +++++++++++++++++++++++++++++++++ .gitlab/script/ghcup_version.sh | 18 +++++--- app/ghcup/GHCup/OptParse/Run.hs | 22 ++++++--- lib/GHCup.hs | 8 ++-- lib/GHCup/Utils/File/Common.hs | 1 - 6 files changed, 149 insertions(+), 18 deletions(-) create mode 100644 .gitlab/ghcup-run.files create mode 100644 .gitlab/ghcup-run.files.windows 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..46f33e9 --- /dev/null +++ b/.gitlab/ghcup-run.files.windows @@ -0,0 +1,81 @@ +./ +./cabal +./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 +./stack.shim diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index e005d40..e8c91f8 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -107,12 +107,18 @@ eghcup set cabal ${CABAL_VERSION} [ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ] [ `eghcup run --cabal ${CABAL_VERSION} -- cabal --numeric-version` = "${CABAL_VERSION}" ] -eghcup run --ghc 8.10.7 --cabal 3.4.0.0 --hls 1.6.1.0 --stack 2.7.3 --install --bindir "$(pwd)/.bin" -expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files" | sort) -actual=$(cd ".bin" && find | sort) -[ "${actual}" = "${expected}" ] -unset actual expected -rm -rf .bin +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 cabal --version diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index 4433a89..b042930 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -209,19 +209,27 @@ run RunOptions{..} runAppState leanAppstate runLogger = do liftIO $ createDirRecursive' bdir liftIO $ canonicalizePath bdir Nothing -> liftIO (getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "ghcup") - r <- addToolsToDir tmp + r <- do + addToolsToDir tmp case r of VRight _ -> do case runCOMMAND of - [] -> liftIO $ putStr tmp + [] -> do + liftIO $ putStr tmp + pure ExitSuccess (cmd:args) -> do newEnv <- liftIO $ addToPath tmp #ifndef IS_WINDOWS - liftIO $ SPP.executeFile cmd True args (Just newEnv) + void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) + pure ExitSuccess #else - liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv) + 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 - pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e pure $ ExitFailure 27 @@ -304,11 +312,11 @@ run RunOptions{..} runAppState leanAppstate runLogger = do Cabal -> do bin <- liftE $ whereIsTool Cabal v cbin <- liftIO $ canonicalizePath bin - lift $ createLink (relativeSymlink tmp cbin) (tmp "cabal") + 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") + lift $ createLink (relativeSymlink tmp cbin) (tmp ("stack" <.> exeExt)) HLS -> do Dirs {..} <- getDirs let v' = _tvVersion v diff --git a/lib/GHCup.hs b/lib/GHCup.hs index da8fed8..49bd93a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -1110,7 +1110,7 @@ setGHC ver sghc mBinDir = do -- first delete the old symlinks (this fixes compatibility issues -- with old ghcup) - when (mBinDir == Nothing) $ + when (isNothing mBinDir) $ case sghc of SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver) SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver @@ -1139,7 +1139,7 @@ setGHC ver sghc mBinDir = do destL <- binarySymLinkDestination binDir fileWithExt lift $ createLink destL fullF - when (mBinDir == Nothing) $ do + when (isNothing mBinDir) $ do -- create symlink for share dir when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS @@ -1263,7 +1263,7 @@ setHLS ver shls mBinDir = do pure f -- first delete the old symlinks - when (mBinDir == Nothing) $ + when (isNothing mBinDir) $ case shls of -- not for legacy SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver @@ -1300,7 +1300,7 @@ setHLS ver shls mBinDir = do lift $ createLink destL wrapper - when (mBinDir == Nothing) $ + when (isNothing mBinDir) $ lift warnAboutHlsCompatibility 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 From 8a16b0de7ca4ce4947e2a843ba9f518f281a9a6e Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 11 Feb 2022 18:51:16 +0100 Subject: [PATCH 7/8] Fix tests --- .gitlab/ghcup-run.files.windows | 6 +++--- .gitlab/script/ghcup_version.sh | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.gitlab/ghcup-run.files.windows b/.gitlab/ghcup-run.files.windows index 46f33e9..8c5d628 100644 --- a/.gitlab/ghcup-run.files.windows +++ b/.gitlab/ghcup-run.files.windows @@ -1,5 +1,5 @@ -./ -./cabal +. +./cabal.exe ./cabal.shim ./ghc-8.10.7.exe ./ghc-8.10.7.shim @@ -77,5 +77,5 @@ ./runhaskell-8.10.7.shim ./runhaskell.exe ./runhaskell.shim -./stack +./stack.exe ./stack.shim diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index e8c91f8..3a10140 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -114,7 +114,7 @@ if [ "${ARCH}" = "64" ] ; then else expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup-run.files" | sort) fi - actual=$(cd ".bin" && find | sort) + actual=$(cd ".bin" && find . | sort) [ "${actual}" = "${expected}" ] unset actual expected rm -rf .bin @@ -148,7 +148,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 @@ -156,7 +156,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 From c859b3ee2b71dd30db9d1ac572270e4a449f0153 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 11 Feb 2022 19:24:39 +0100 Subject: [PATCH 8/8] Exclude FreeBSD from 'ghcup run' test --- .gitlab/script/ghcup_version.sh | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 3a10140..3cdab04 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -107,17 +107,19 @@ 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 [ "${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) +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 - actual=$(cd ".bin" && find . | sort) - [ "${actual}" = "${expected}" ] - unset actual expected - rm -rf .bin fi cabal --version