ghcup 0.1.17.6 → 0.1.17.8
raw patch · 15 files changed
+304/−251 lines, 15 files
Files
- CHANGELOG.md +11/−0
- app/ghcup/BrickMain.hs +6/−5
- app/ghcup/GHCup/OptParse.hs +3/−3
- app/ghcup/GHCup/OptParse/Compile.hs +3/−3
- app/ghcup/GHCup/OptParse/Install.hs +9/−9
- app/ghcup/GHCup/OptParse/Run.hs +22/−26
- app/ghcup/GHCup/OptParse/Upgrade.hs +8/−5
- app/ghcup/Main.hs +18/−28
- ghcup.cabal +2/−13
- lib/GHCup.hs +170/−147
- lib/GHCup/Errors.hs +19/−0
- lib/GHCup/Types.hs +13/−0
- lib/GHCup/Utils.hs +11/−10
- lib/GHCup/Utils/File/Common.hs +7/−0
- lib/GHCup/Utils/Prelude.hs +2/−2
CHANGELOG.md view
@@ -1,5 +1,16 @@ # Revision history for ghcup +## 0.1.17.8 -- XXXX-XX-XX++* Fix HLS build not cleaning up properly on failed installations, fixes [#361](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/361)+ - this also fixes a significant bug on installation failure when combining `--isolate DIR` with `--force`+* Fix parsing of symlinks with multiple slashes, wrt [#353](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/353)+* Re-enable upgrade functionality for all configurations wrt [#250](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/250)++## 0.1.17.7 -- 2022-04-21++* Fix `ghcup run` on windows wrt [#345](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/345)+ ## 0.1.17.6 -- 2022-03-18 * Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242)
app/ghcup/BrickMain.hs view
@@ -437,6 +437,7 @@ , TarDirDoesNotExist , FileAlreadyExistsError , ProcessError+ , GHCupShadowed ] run (do@@ -446,19 +447,19 @@ case lTool of GHC -> do let vi = getVersionInfo lVer GHC dls- liftE $ installGHCBin lVer Nothing False $> (vi, dirs, ce)+ liftE $ installGHCBin lVer GHCupInternal False $> (vi, dirs, ce) Cabal -> do let vi = getVersionInfo lVer Cabal dls- liftE $ installCabalBin lVer Nothing False $> (vi, dirs, ce)+ liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) GHCup -> do let vi = snd <$> getLatest dls GHCup- liftE $ upgradeGHCup Nothing False $> (vi, dirs, ce)+ liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) HLS -> do let vi = getVersionInfo lVer HLS dls- liftE $ installHLSBin lVer Nothing False $> (vi, dirs, ce)+ liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) Stack -> do let vi = getVersionInfo lVer Stack dls- liftE $ installStackBin lVer Nothing False $> (vi, dirs, ce)+ liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) ) >>= \case VRight (vi, Dirs{..}, Just ce) -> do
app/ghcup/GHCup/OptParse.hs view
@@ -96,7 +96,7 @@ | Config ConfigCommand | Whereis WhereisOptions WhereisCommand #ifndef DISABLE_UPGRADE- | Upgrade UpgradeOpts Bool+ | Upgrade UpgradeOpts Bool Bool #endif | ToolRequirements ToolReqOpts | ChangeLog ChangeLogOptions@@ -222,18 +222,18 @@ (info (List <$> listOpts <**> helper) (progDesc "Show available GHCs and other tools") )-#ifndef DISABLE_UPGRADE <> command "upgrade" (info ( (Upgrade <$> upgradeOptsP <*> switch (short 'f' <> long "force" <> help "Force update")+ <*> switch+ (long "fail-if-shadowed" <> help "Fails after upgrading if the upgraded ghcup binary is shadowed by something else in PATH (useful for CI)") ) <**> helper ) (progDesc "Upgrade ghcup") )-#endif <> command "compile" ( Compile
app/ghcup/GHCup/OptParse/Compile.hs view
@@ -283,7 +283,7 @@ (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help "The git commit/branch/ref to build from" ) <*>- optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)"+ optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)" <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"]) )) )))@@ -469,7 +469,7 @@ ghcs jobs ovewrwiteVer- isolateDir+ (maybe GHCupInternal IsolateDir isolateDir) cabalProject cabalProjectLocal patches@@ -524,7 +524,7 @@ addConfArgs buildFlavour hadrian- isolateDir+ (maybe GHCupInternal IsolateDir isolateDir) GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (_tvVersion targetVer) GHC dls when setCompile $ void $ liftE $
app/ghcup/GHCup/OptParse/Install.hs view
@@ -216,10 +216,10 @@ Nothing -> False Just GHC -> False Just _ -> True- + -------------- --[ Footer ]-- --------------@@ -395,7 +395,7 @@ (v, vi) <- liftE $ fromVersion instVer GHC void $ liftE $ sequenceE (installGHCBin (_tvVersion v)- isolateDir+ (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing@@ -406,7 +406,7 @@ void $ liftE $ sequenceE (installGHCBindist (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (_tvVersion v)- isolateDir+ (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing@@ -467,7 +467,7 @@ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal void $ liftE $ sequenceE (installCabalBin v- isolateDir+ (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v pure vi@@ -477,7 +477,7 @@ void $ liftE $ sequenceE (installCabalBindist (DownloadInfo uri Nothing "") v- isolateDir+ (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v pure vi@@ -518,7 +518,7 @@ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS void $ liftE $ sequenceE (installHLSBin v- isolateDir+ (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing pure vi@@ -529,7 +529,7 @@ void $ liftE $ sequenceE (installHLSBindist (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "") v- isolateDir+ (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing pure vi@@ -578,7 +578,7 @@ (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack void $ liftE $ sequenceE (installStackBin v- isolateDir+ (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v pure vi@@ -588,7 +588,7 @@ void $ liftE $ sequenceE (installStackBindist (DownloadInfo uri Nothing "") v- isolateDir+ (maybe GHCupInternal IsolateDir isolateDir) forceInstall ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v pure vi
app/ghcup/GHCup/OptParse/Run.hs view
@@ -61,6 +61,7 @@ , runHLSVer :: Maybe ToolVersion , runStackVer :: Maybe ToolVersion , runBinDir :: Maybe FilePath+ , runQuick :: Bool , runCOMMAND :: [String] } @@ -70,8 +71,8 @@ --[ Parsers ]-- --------------- - - ++ runOpts :: Parser RunOptions runOpts = RunOptions@@ -121,6 +122,8 @@ <> completer (bashCompleter "directory") ) )+ <*> switch+ (short 'q' <> long "quick" <> help "Avoid any expensive work (such as downloads, version/tag resolution etc.). Disables --install.") <*> 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.")) @@ -219,29 +222,15 @@ -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode run RunOptions{..} runAppState leanAppstate runLogger = do- r <- if or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool'+ r <- if not runQuick then runRUN runAppState $ do toolchain <- liftE resolveToolchainFull- tmp <- case runBinDir of- Just bindir -> do- liftIO $ createDirRecursive' bindir- liftIO $ canonicalizePath bindir- Nothing -> do- d <- liftIO $ predictableTmpDir toolchain- liftIO $ createDirRecursive' d- liftIO $ canonicalizePath d+ tmp <- liftIO $ createTmpDir toolchain liftE $ installToolChainFull toolchain tmp pure tmp else runLeanRUN leanAppstate $ do toolchain <- resolveToolchain- tmp <- case runBinDir of- Just bindir -> do- liftIO $ createDirRecursive' bindir- liftIO $ canonicalizePath bindir- Nothing -> do- d <- liftIO $ predictableTmpDir toolchain- liftIO $ createDirRecursive' d- liftIO $ canonicalizePath d+ tmp <- liftIO $ createTmpDir toolchain liftE $ installToolChain toolchain tmp pure tmp case r of@@ -269,9 +258,16 @@ where - isToolTag :: ToolVersion -> Bool- isToolTag (ToolTag _) = True- isToolTag _ = False+ createTmpDir :: Toolchain -> IO FilePath+ createTmpDir toolchain =+ case runBinDir of+ Just bindir -> do+ createDirRecursive' bindir+ canonicalizePath bindir+ Nothing -> do+ d <- predictableTmpDir toolchain+ createDirRecursive' d+ canonicalizePath d -- TODO: doesn't work for cross resolveToolchainFull :: ( MonadFail m@@ -351,25 +347,25 @@ Just (GHC, v) -> do unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin (_tvVersion v)- Nothing+ GHCupInternal False setTool GHC v tmp Just (Cabal, v) -> do unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin (_tvVersion v)- Nothing+ GHCupInternal False setTool Cabal v tmp Just (Stack, v) -> do unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin (_tvVersion v)- Nothing+ GHCupInternal False setTool Stack v tmp Just (HLS, v) -> do unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin (_tvVersion v)- Nothing+ GHCupInternal False setTool HLS v tmp _ -> pure ()
app/ghcup/GHCup/OptParse/Upgrade.hs view
@@ -59,15 +59,16 @@ --[ Parsers ]-- --------------- - + upgradeOptsP :: Parser UpgradeOpts upgradeOptsP = flag' UpgradeInplace (short 'i' <> long "inplace" <> help- "Upgrade ghcup in-place (wherever it's at)"+ "Upgrade ghcup in-place" )- <|> ( UpgradeAt+ <|>+ ( UpgradeAt <$> option str (short 't' <> long "target" <> metavar "TARGET_DIR" <> help@@ -92,6 +93,7 @@ , FileDoesNotExistError , CopyError , DownloadFailed+ , GHCupShadowed ] @@ -120,18 +122,19 @@ ) => UpgradeOpts -> Bool+ -> Bool -> Dirs -> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a)) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode-upgrade uOpts force' Dirs{..} runAppState runLogger = do+upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do target <- case uOpts of UpgradeInplace -> Just <$> liftIO getExecutablePath (UpgradeAt p) -> pure $ Just p UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt)) runUpgrade runAppState (do- v' <- liftE $ upgradeGHCup target force'+ v' <- liftE $ upgradeGHCup target force' fatal GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo pure (v', dls) ) >>= \case
app/ghcup/Main.hs view
@@ -141,9 +141,7 @@ ) let listCommands = infoOption ("install set rm install-cabal list"-#ifndef DISABLE_UPGRADE <> " upgrade"-#endif <> " compile debug-info tool-requirements changelog" ) ( long "list-commands"@@ -245,14 +243,10 @@ alreadyInstalling' <- alreadyInstalling optCommand newTool when (not alreadyInstalling') $ case t of-#ifdef DISABLE_UPGRADE- GHCup -> pure ()-#else GHCup -> runLogger $ logWarn ("New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'")-#endif _ -> runLogger $ logWarn ("New " <> T.pack (prettyShow t)@@ -296,26 +290,24 @@ s' <- appState liftIO $ brickMain s' >> pure ExitSuccess #endif- Install installCommand -> install installCommand settings appState runLogger- InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger- Set setCommand -> set setCommand runAppState runLeanAppState runLogger- UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger- List lo -> list lo no_color runAppState- Rm rmCommand -> rm rmCommand runAppState runLogger- DInfo -> dinfo runAppState runLogger- Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger- Config configCommand -> config configCommand settings keybindings runLogger+ Install installCommand -> install installCommand settings appState runLogger+ InstallCabalLegacy iopts -> install (Left (InstallCabal iopts)) settings appState runLogger+ Set setCommand -> set setCommand runAppState runLeanAppState runLogger+ UnSet unsetCommand -> unset unsetCommand runLeanAppState runLogger+ List lo -> list lo no_color runAppState+ Rm rmCommand -> rm rmCommand runAppState runLogger+ DInfo -> dinfo runAppState runLogger+ Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger+ Config configCommand -> config configCommand settings keybindings runLogger Whereis whereisOptions- whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger-#ifndef DISABLE_UPGRADE- Upgrade uOpts force' -> upgrade uOpts force' dirs runAppState runLogger-#endif- ToolRequirements topts -> toolRequirements topts runAppState runLogger- ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger- Nuke -> nuke appState runLogger- Prefetch pfCom -> prefetch pfCom runAppState runLogger- GC gcOpts -> gc gcOpts runAppState runLogger- Run runCommand -> run runCommand appState leanAppstate runLogger+ whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger+ Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger+ ToolRequirements topts -> toolRequirements topts runAppState runLogger+ ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger+ Nuke -> nuke appState runLogger+ Prefetch pfCom -> prefetch pfCom runAppState runLogger+ GC gcOpts -> gc gcOpts runAppState runLogger+ Run runCommand -> run runCommand appState leanAppstate runLogger case res of ExitSuccess -> pure ()@@ -353,9 +345,7 @@ (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver })) (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver-#ifndef DISABLE_UPGRADE- alreadyInstalling (Upgrade _ _) (GHCup, _) = pure True-#endif+ alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True alreadyInstalling _ _ = pure False cmp' :: ( HasLog env
ghcup.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcup-version: 0.1.17.6+version: 0.1.17.8 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020@@ -48,13 +48,6 @@ default: False manual: True -flag disable-upgrade- description:- Disable upgrade functionality. This is mainly to support brew packagers.-- default: False- manual: True- library exposed-modules: GHCup@@ -204,6 +197,7 @@ GHCup.OptParse.Set GHCup.OptParse.ToolRequirements GHCup.OptParse.UnSet+ GHCup.OptParse.Upgrade GHCup.OptParse.Whereis hs-source-dirs: app/ghcup@@ -277,11 +271,6 @@ if flag(no-exe) buildable: False - if flag(disable-upgrade)- cpp-options: -DDISABLE_UPGRADE-- else- other-modules: GHCup.OptParse.Upgrade test-suite ghcup-test type: exitcode-stdio-1.0
lib/GHCup.hs view
@@ -187,7 +187,7 @@ ) => DownloadInfo -- ^ where/how to download -> Version -- ^ the version to install- -> Maybe FilePath -- ^ isolated filepath if user passed any+ -> InstallDir -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled@@ -205,22 +205,22 @@ ] m ()-installGHCBindist dlinfo ver isoFilepath forceInstall = do+installGHCBindist dlinfo ver installDir forceInstall = do let tver = mkTVer ver lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver- + if | not forceInstall , regularGHCInstalled- , Nothing <- isoFilepath -> do+ , GHCupInternal <- installDir -> do throwE $ AlreadyInstalled GHC ver | forceInstall , regularGHCInstalled- , Nothing <- isoFilepath -> do+ , GHCupInternal <- installDir -> do lift $ logInfo "Removing the currently installed GHC version first!" liftE $ rmGHCVer tver @@ -229,18 +229,19 @@ -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing - -- prepare paths- ghcdir <- lift $ ghcupGHCDir tver toolchainSanityChecks - case isoFilepath of- Just isoDir -> do -- isolated install+ case installDir of+ IsolateDir isoDir -> do -- isolated install lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir- liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver forceInstall- Nothing -> do -- regular install- liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver forceInstall+ liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall+ GHCupInternal -> do -- regular install+ -- prepare paths+ ghcdir <- lift $ ghcupGHCDir tver + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall+ -- make symlinks & stuff when regular install, liftE $ postGHCInstall tver @@ -271,7 +272,7 @@ ) => FilePath -- ^ Path to the packed GHC bindist -> Maybe TarDir -- ^ Subdir of the archive- -> FilePath -- ^ Path to install to+ -> InstallDirResolved -> Version -- ^ The GHC version -> Bool -- ^ Force install -> Excepts@@ -297,9 +298,13 @@ workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) msubdir- + liftE $ runBuildAction tmpUnpack- (Just inst)+ (case inst of+ IsolateDirResolved _ -> Nothing -- don't clean up for isolated installs, since that'd potentially delete other+ -- user files if '--force' is supplied+ GHCupDir d -> Just d+ ) (installUnpackedGHC workdir inst ver) @@ -315,11 +320,11 @@ , MonadUnliftIO m , MonadMask m )- => FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)- -> FilePath -- ^ Path to install to- -> Version -- ^ The GHC version+ => FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)+ -> InstallDirResolved -- ^ Path to install to+ -> Version -- ^ The GHC version -> Excepts '[ProcessError] m ()-installUnpackedGHC path inst ver+installUnpackedGHC path (fromInstallDir -> inst) ver | isWindows = do lift $ logInfo "Installing GHC (this may take a while)" -- Windows bindists are relocatable and don't need@@ -340,7 +345,7 @@ lift $ logInfo "Installing GHC (this may take a while)" lEM $ execLogged "sh"- ("./configure" : ("--prefix=" <> inst) + ("./configure" : ("--prefix=" <> inst) : alpineArgs ) (Just path)@@ -369,7 +374,7 @@ , MonadUnliftIO m ) => Version -- ^ the version to install- -> Maybe FilePath -- ^ isolated install filepath, if user passed any+ -> InstallDir -> Bool -- ^ force install -> Excepts '[ AlreadyInstalled@@ -387,9 +392,9 @@ ] m ()-installGHCBin ver isoFilepath forceInstall = do+installGHCBin ver installDir forceInstall = do dlinfo <- liftE $ getDownloadInfo GHC ver- liftE $ installGHCBindist dlinfo ver isoFilepath forceInstall+ liftE $ installGHCBindist dlinfo ver installDir forceInstall -- | Like 'installCabalBin', except takes the 'DownloadInfo' as@@ -408,8 +413,8 @@ ) => DownloadInfo -> Version- -> Maybe FilePath -- ^ isolated install filepath, if user provides any.- -> Bool -- ^ Force install + -> InstallDir+ -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled , CopyError@@ -425,7 +430,7 @@ ] m ()-installCabalBindist dlinfo ver isoFilepath forceInstall = do+installCabalBindist dlinfo ver installDir forceInstall = do lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver PlatformRequest {..} <- lift getPlatformReq@@ -437,18 +442,18 @@ if | not forceInstall , regularCabalInstalled- , Nothing <- isoFilepath -> do+ , GHCupInternal <- installDir -> do throwE $ AlreadyInstalled Cabal ver- + | forceInstall , regularCabalInstalled- , Nothing <- isoFilepath -> do+ , GHCupInternal <- installDir -> do lift $ logInfo "Removing the currently installed version first!" liftE $ rmCabalVer ver | otherwise -> pure () - + -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -460,34 +465,37 @@ -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - case isoFilepath of- Just isoDir -> do -- isolated install+ case installDir of+ IsolateDir isoDir -> do -- isolated install lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir- liftE $ installCabalUnpacked workdir isoDir Nothing forceInstall+ liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall - Nothing -> do -- regular install- liftE $ installCabalUnpacked workdir binDir (Just ver) forceInstall+ GHCupInternal -> do -- regular install+ liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall - + -- | Install an unpacked cabal distribution.Symbol installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)- -> FilePath -- ^ Path to install to- -> Maybe Version -- ^ Nothing for isolated install+ -> InstallDirResolved -- ^ Path to install to+ -> Version -> Bool -- ^ Force Install -> Excepts '[CopyError, FileAlreadyExistsError] m ()-installCabalUnpacked path inst mver' forceInstall = do+installCabalUnpacked path inst ver forceInstall = do lift $ logInfo "Installing cabal" let cabalFile = "cabal"- liftIO $ createDirRecursive' inst+ liftIO $ createDirRecursive' (fromInstallDir inst) let destFileName = cabalFile- <> maybe "" (("-" <>) . T.unpack . prettyVer) mver'+ <> (case inst of+ IsolateDirResolved _ -> ""+ GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver+ ) <> exeExt- let destPath = inst </> destFileName+ let destPath = fromInstallDir inst </> destFileName unless forceInstall -- Overwrite it when it IS a force install (liftE $ throwIfFileAlreadyExists destPath)- + copyFileE (path </> cabalFile <> exeExt) destPath@@ -510,7 +518,7 @@ , MonadFail m ) => Version- -> Maybe FilePath -- isolated install Path, if user provided any+ -> InstallDir -> Bool -- force install -> Excepts '[ AlreadyInstalled@@ -527,9 +535,9 @@ ] m ()-installCabalBin ver isoFilepath forceInstall = do+installCabalBin ver installDir forceInstall = do dlinfo <- liftE $ getDownloadInfo Cabal ver- installCabalBindist dlinfo ver isoFilepath forceInstall+ installCabalBindist dlinfo ver installDir forceInstall -- | Like 'installHLSBin, except takes the 'DownloadInfo' as@@ -548,8 +556,8 @@ ) => DownloadInfo -> Version- -> Maybe FilePath -- ^ isolated install path, if user passed any- -> Bool -- ^ Force install+ -> InstallDir -- ^ isolated install path, if user passed any+ -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled , CopyError@@ -567,7 +575,7 @@ ] m ()-installHLSBindist dlinfo ver isoFilepath forceInstall = do+installHLSBindist dlinfo ver installDir forceInstall = do lift $ logDebug $ "Requested to install hls version " <> prettyVer ver PlatformRequest {..} <- lift getPlatformReq@@ -578,17 +586,17 @@ if | not forceInstall , regularHLSInstalled- , Nothing <- isoFilepath -> do -- regular install+ , GHCupInternal <- installDir -> do -- regular install throwE $ AlreadyInstalled HLS ver | forceInstall , regularHLSInstalled- , Nothing <- isoFilepath -> do -- regular forced install+ , GHCupInternal <- installDir -> do -- regular forced install lift $ logInfo "Removing the currently installed version of HLS before force installing!" liftE $ rmHLSVer ver | otherwise -> pure ()- + -- download (or use cached version) dl <- liftE $ downloadCached dlinfo Nothing @@ -604,22 +612,23 @@ if | not forceInstall , not legacy- , (Just fp) <- isoFilepath -> liftE $ installDestSanityCheck fp+ , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp) | otherwise -> pure () - case isoFilepath of- Just isoDir -> do+ case installDir of+ IsolateDir isoDir -> do lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir if legacy- then liftE $ installHLSUnpackedLegacy workdir isoDir Nothing forceInstall- else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir isoDir ver+ then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall+ else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver - Nothing -> do+ GHCupInternal -> do if legacy- then liftE $ installHLSUnpackedLegacy workdir binDir (Just ver) forceInstall+ then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall else do inst <- ghcupHLSDir ver- liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir inst ver+ liftE $ runBuildAction tmpUnpack (Just inst)+ $ installHLSUnpacked workdir (GHCupDir inst) ver liftE $ setHLS ver SetHLS_XYZ Nothing @@ -631,10 +640,10 @@ -- | Install an unpacked hls distribution. installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)- -> FilePath -- ^ Path to install to+ -> InstallDirResolved -- ^ Path to install to -> Version -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()-installHLSUnpacked path inst _ = do+installHLSUnpacked path (fromInstallDir -> inst) _ = do lift $ logInfo "Installing HLS" liftIO $ createDirRecursive' inst lEM $ make ["PREFIX=" <> inst, "install"] (Just path)@@ -642,13 +651,13 @@ -- | Install an unpacked hls distribution (legacy). installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)- -> FilePath -- ^ Path to install to- -> Maybe Version -- ^ Nothing for isolated install+ -> InstallDirResolved -- ^ Path to install to+ -> Version -> Bool -- ^ is it a force install -> Excepts '[CopyError, FileAlreadyExistsError] m ()-installHLSUnpackedLegacy path inst mver' forceInstall = do+installHLSUnpackedLegacy path installDir ver forceInstall = do lift $ logInfo "Installing HLS"- liftIO $ createDirRecursive' inst+ liftIO $ createDirRecursive' (fromInstallDir installDir) -- install haskell-language-server-<ghcver> bins@(_:_) <- liftIO $ findFiles@@ -659,15 +668,18 @@ ) forM_ bins $ \f -> do let toF = dropSuffix exeExt f- <> maybe "" (("~" <>) . T.unpack . prettyVer) mver'+ <> (case installDir of+ IsolateDirResolved _ -> ""+ GHCupDir _ -> ("~" <>) . T.unpack . prettyVer $ ver+ ) <> exeExt let srcPath = path </> f- let destPath = inst </> toF+ let destPath = fromInstallDir installDir </> toF unless forceInstall -- if it is a force install, overwrite it. (liftE $ throwIfFileAlreadyExists destPath)- + copyFileE srcPath destPath@@ -676,18 +688,21 @@ -- install haskell-language-server-wrapper let wrapper = "haskell-language-server-wrapper" toF = wrapper- <> maybe "" (("-" <>) . T.unpack . prettyVer) mver'+ <> (case installDir of+ IsolateDirResolved _ -> ""+ GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver+ ) <> exeExt srcWrapperPath = path </> wrapper <> exeExt- destWrapperPath = inst </> toF+ destWrapperPath = fromInstallDir installDir </> toF unless forceInstall (liftE $ throwIfFileAlreadyExists destWrapperPath)- + copyFileE srcWrapperPath destWrapperPath- + lift $ chmod_755 destWrapperPath @@ -708,7 +723,7 @@ , MonadFail m ) => Version- -> Maybe FilePath -- isolated install Dir (if any)+ -> InstallDir -> Bool -- force install -> Excepts '[ AlreadyInstalled@@ -727,9 +742,9 @@ ] m ()-installHLSBin ver isoFilepath forceInstall = do+installHLSBin ver installDir forceInstall = do dlinfo <- liftE $ getDownloadInfo HLS ver- installHLSBindist dlinfo ver isoFilepath forceInstall+ installHLSBindist dlinfo ver installDir forceInstall compileHLS :: ( MonadMask m@@ -749,7 +764,7 @@ -> [Version] -> Maybe Int -> Maybe Version- -> Maybe FilePath+ -> InstallDir -> Maybe (Either FilePath URI) -> Maybe URI -> Maybe (Either FilePath [URI]) -- ^ patches@@ -764,7 +779,7 @@ , BuildFailed , NotInstalled ] m Version-compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patches cabalArgs = do+compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo Dirs { .. } <- lift getDirs@@ -805,7 +820,7 @@ , "origin" , fromString rep ] - let fetch_args = + let fetch_args = [ "fetch" , "--depth" , "1"@@ -837,8 +852,8 @@ workdir Nothing (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do- let installDir = workdir </> "out"- liftIO $ createDirRecursive' installDir+ let tmpInstallDir = workdir </> "out"+ liftIO $ createDirRecursive' tmpInstallDir -- apply patches liftE $ applyAnyPatch patches workdir@@ -861,8 +876,8 @@ cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False copyFileE cpl (workdir </> cp <.> "local") artifacts <- forM (sort ghcs) $ \ghc -> do- let ghcInstallDir = installDir </> T.unpack (prettyVer ghc)- liftIO $ createDirRecursive' installDir+ let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)+ liftIO $ createDirRecursive' tmpInstallDir lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc liftE $ lEM @_ @'[ProcessError] $ execLogged "cabal" ( [ "v2-install"@@ -885,17 +900,17 @@ forM_ artifacts $ \artifact -> do liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)- (installDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)+ (tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt) liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)- (installDir </> "haskell-language-server-wrapper" <.> exeExt)+ (tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt) liftIO $ rmPathForcibly artifact - case isolateDir of- Just isoDir -> do+ case installDir of+ IsolateDir isoDir -> do lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir- liftE $ installHLSUnpackedLegacy installDir isoDir Nothing True- Nothing -> do- liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True+ liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True+ GHCupInternal -> do+ liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupDir binDir) installVer True ) pure installVer@@ -919,7 +934,7 @@ , MonadFail m ) => Version- -> Maybe FilePath -- ^ isolate install Dir (if any)+ -> InstallDir -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled@@ -936,9 +951,9 @@ ] m ()-installStackBin ver isoFilepath forceInstall = do+installStackBin ver installDir forceInstall = do dlinfo <- liftE $ getDownloadInfo Stack ver- installStackBindist dlinfo ver isoFilepath forceInstall+ installStackBindist dlinfo ver installDir forceInstall -- | Like 'installStackBin', except takes the 'DownloadInfo' as@@ -957,7 +972,7 @@ ) => DownloadInfo -> Version- -> Maybe FilePath -- ^ isolate install Dir (if any)+ -> InstallDir -> Bool -- ^ Force install -> Excepts '[ AlreadyInstalled@@ -974,7 +989,7 @@ ] m ()-installStackBindist dlinfo ver isoFilepath forceInstall = do+installStackBindist dlinfo ver installDir forceInstall = do lift $ logDebug $ "Requested to install stack version " <> prettyVer ver PlatformRequest {..} <- lift getPlatformReq@@ -985,12 +1000,12 @@ if | not forceInstall , regularStackInstalled- , Nothing <- isoFilepath -> do+ , GHCupInternal <- installDir -> do throwE $ AlreadyInstalled Stack ver | forceInstall , regularStackInstalled- , Nothing <- isoFilepath -> do+ , GHCupInternal <- installDir -> do lift $ logInfo "Removing the currently installed version of Stack first!" liftE $ rmStackVer ver @@ -1007,33 +1022,36 @@ -- the subdir of the archive where we do the work workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - case isoFilepath of- Just isoDir -> do -- isolated install+ case installDir of+ IsolateDir isoDir -> do -- isolated install lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir- liftE $ installStackUnpacked workdir isoDir Nothing forceInstall- Nothing -> do -- regular install- liftE $ installStackUnpacked workdir binDir (Just ver) forceInstall+ liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall+ GHCupInternal -> do -- regular install+ liftE $ installStackUnpacked workdir (GHCupDir binDir) ver forceInstall -- | Install an unpacked stack distribution. installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)- -> FilePath -- ^ Path to install to- -> Maybe Version -- ^ Nothing for isolated installs+ -> InstallDirResolved+ -> Version -> Bool -- ^ Force install -> Excepts '[CopyError, FileAlreadyExistsError] m ()-installStackUnpacked path inst mver' forceInstall = do+installStackUnpacked path installDir ver forceInstall = do lift $ logInfo "Installing stack" let stackFile = "stack"- liftIO $ createDirRecursive' inst+ liftIO $ createDirRecursive' (fromInstallDir installDir) let destFileName = stackFile- <> maybe "" (("-" <>) . T.unpack . prettyVer) mver'+ <> (case installDir of+ IsolateDirResolved _ -> ""+ GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver+ ) <> exeExt- destPath = inst </> destFileName+ destPath = fromInstallDir installDir </> destFileName unless forceInstall (liftE $ throwIfFileAlreadyExists destPath)- + copyFileE (path </> stackFile <> exeExt) destPath@@ -1099,7 +1117,7 @@ SetGHC_XY -> do handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)- $ do + $ do (mj, mi) <- getMajorMinorV (_tvVersion ver) let major' = intToText mj <> "." <> intToText mi pure $ Just (file <> "-" <> T.unpack major')@@ -1223,7 +1241,7 @@ , MonadUnliftIO m ) => Version- -> SetHLS -- Nothing for legacy+ -> SetHLS -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin -- and don't want mess with other versions -> Excepts '[NotInstalled] m ()@@ -1357,7 +1375,7 @@ "Haskell IDE support may not work until this is fixed." <> "\n" <> "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <> T.pack (prettyShow supportedGHC)- + _ -> return () ------------------@@ -1962,7 +1980,7 @@ handleRm $ rmEnvFile envFilePath handleRm $ rmConfFile confFilePath- + -- for xdg dirs, the order matters here handleRm $ rmDir logsDir handleRm $ rmDir cacheDir@@ -2036,8 +2054,8 @@ cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>) forM_ cs removeEmptyDirsRecursive hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp- + -- we expect only files inside cache/log dir -- we report remaining files/dirs later, -- hence the force/quiet mode in these delete functions below.@@ -2121,7 +2139,7 @@ -> [Text] -- ^ additional args to ./configure -> Maybe String -- ^ build flavour -> Bool- -> Maybe FilePath -- ^ isolate dir+ -> InstallDir -> Excepts '[ AlreadyInstalled , BuildFailed@@ -2146,7 +2164,7 @@ ] m GHCTargetVersion-compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian isolateDir+compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo@@ -2187,7 +2205,7 @@ , "origin" , fromString rep ] - let fetch_args = + let fetch_args = [ "fetch" , "--depth" , "1"@@ -2219,18 +2237,18 @@ alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) when alreadyInstalled $ do- case isolateDir of- Just isoDir ->+ case installDir of+ IsolateDir isoDir -> lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir- Nothing ->+ GHCupInternal -> lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version." lift $ logWarn "...waiting for 10 seconds before continuing, you can still abort..." liftIO $ threadDelay 10000000 -- give the user a sec to intervene - ghcdir <- case isolateDir of- Just isoDir -> pure isoDir- Nothing -> lift $ ghcupGHCDir installVer+ ghcdir <- case installDir of+ IsolateDir isoDir -> pure $ IsolateDirResolved isoDir+ GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) (mBindist, bmk) <- liftE $ runBuildAction tmpUnpack@@ -2243,13 +2261,13 @@ pure (b, bmk) ) - case isolateDir of- Nothing ->+ case installDir of+ GHCupInternal -> -- only remove old ghc in regular installs when alreadyInstalled $ do lift $ logInfo "Deleting existing installation" liftE $ rmGHCVer installVer- + _ -> pure () forM_ mBindist $ \bindist -> do@@ -2259,21 +2277,21 @@ (installVer ^. tvVersion) False -- not a force install, since we already overwrite when compiling. - liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk- - case isolateDir of+ liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk++ case installDir of -- set and make symlinks for regular (non-isolated) installs- Nothing -> do+ GHCupInternal -> do reThrowAll GHCupSetError $ postGHCInstall installVer -- restore when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing- + _ -> pure () pure installVer where- defaultConf = + defaultConf = let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) in case targetGhc of@@ -2292,7 +2310,7 @@ ) => GHCTargetVersion -> FilePath- -> FilePath+ -> InstallDirResolved -> Excepts '[ FileDoesNotExistError , HadrianNotFound@@ -2351,7 +2369,7 @@ ) => GHCTargetVersion -> FilePath- -> FilePath+ -> InstallDirResolved -> Excepts '[ FileDoesNotExistError , HadrianNotFound@@ -2486,7 +2504,7 @@ ) => GHCTargetVersion -> FilePath- -> FilePath+ -> InstallDirResolved -> Excepts '[ FileDoesNotExistError , InvalidBuildConfig@@ -2497,7 +2515,7 @@ ] m ()- configureBindist tver workdir ghcdir = do+ configureBindist tver workdir (fromInstallDir -> ghcdir) = do lift $ logInfo [s|configuring build|] if | _tvVersion tver >= [vver|8.8.0|] -> do@@ -2587,6 +2605,7 @@ => Maybe FilePath -- ^ full file destination to write ghcup into -> Bool -- ^ whether to force update regardless -- of currently installed version+ -> Bool -- ^ whether to throw an error if ghcup is shadowed -> Excepts '[ CopyError , DigestError@@ -2595,15 +2614,16 @@ , DownloadFailed , NoDownload , NoUpdate+ , GHCupShadowed ] m Version-upgradeGHCup mtarget force' = do+upgradeGHCup mtarget force' fatal = do Dirs {..} <- lift getDirs GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo lift $ logInfo "Upgrading GHCup..."- let latestVer = fromJust $ fst <$> getLatest dls GHCup+ let latestVer = fst (fromJust (getLatest dls GHCup)) (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer "" when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate dli <- liftE $ getDownloadInfo GHCup latestVer@@ -2625,15 +2645,18 @@ lift $ logWarn $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup." liftIO (isShadowed destFile) >>= \case Nothing -> pure ()- Just pa -> lift $ logWarn $ "ghcup is shadowed by "- <> T.pack pa- <> ". The upgrade will not be in effect, unless you remove "- <> T.pack pa- <> " or make sure "- <> T.pack destDir- <> " comes before "- <> T.pack (takeFileName pa)- <> " in PATH."+ Just pa+ | fatal -> throwE (GHCupShadowed pa destFile latestVer)+ | otherwise ->+ lift $ logWarn $ "ghcup is shadowed by "+ <> T.pack pa+ <> ". The upgrade will not be in effect, unless you remove "+ <> T.pack pa+ <> " or make sure "+ <> T.pack destDir+ <> " comes before "+ <> T.pack (takeDirectory pa)+ <> " in PATH." pure latestVer
lib/GHCup/Errors.hs view
@@ -27,6 +27,7 @@ import Data.Text ( Text ) import Data.Versions import Haskus.Utils.Variant+import System.FilePath import Text.PrettyPrint hiding ( (<>) ) import Text.PrettyPrint.HughesPJClass hiding ( (<>) ) import URI.ByteString@@ -291,6 +292,24 @@ pPrint HadrianNotFound = text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?" +data GHCupShadowed = GHCupShadowed+ FilePath -- shadow binary+ FilePath -- upgraded binary+ Version -- upgraded version+ deriving Show++instance Pretty GHCupShadowed where+ pPrint (GHCupShadowed sh up _) =+ text ("ghcup is shadowed by "+ <> sh+ <> ". The upgrade will not be in effect, unless you remove "+ <> sh+ <> " or make sure "+ <> takeDirectory up+ <> " comes before "+ <> takeDirectory sh+ <> " in PATH."+ ) ------------------------- --[ High-level errors ]--
lib/GHCup/Types.hs view
@@ -628,3 +628,16 @@ deriving (Eq, Show) makeLenses ''CapturedProcess+++data InstallDir = IsolateDir FilePath+ | GHCupInternal+ deriving (Eq, Show)++data InstallDirResolved = IsolateDirResolved FilePath+ | GHCupDir FilePath+ deriving (Eq, Show)++fromInstallDir :: InstallDirResolved -> FilePath+fromInstallDir (IsolateDirResolved fp) = fp+fromInstallDir (GHCupDir fp) = fp
lib/GHCup/Utils.hs view
@@ -317,10 +317,10 @@ MP.setInput rest pure x )- <* pathSep+ <* MP.some pathSep <* MP.takeRest <* MP.eof- ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep+ ghcSubPath = MP.some pathSep <* MP.chunk "ghc" *> MP.some pathSep -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>. -- If a dir cannot be parsed, returns left.@@ -398,10 +398,10 @@ cabalParse = MP.chunk "cabal-" *> version' -- parses any path component ending with path separator, -- e.g. "foo/"- stripPathComponet = parseUntil1 pathSep *> pathSep+ stripPathComponet = parseUntil1 pathSep *> MP.some pathSep -- parses an absolute path up until the last path separator, -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"- stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)+ stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) -- parses a relative path up until the last path separator, -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" stripRelativePath = MP.many (MP.try stripPathComponet)@@ -492,10 +492,10 @@ cabalParse = MP.chunk "stack-" *> version' -- parses any path component ending with path separator, -- e.g. "foo/"- stripPathComponet = parseUntil1 pathSep *> pathSep+ stripPathComponet = parseUntil1 pathSep *> MP.some pathSep -- parses an absolute path up until the last path separator, -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"- stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)+ stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) -- parses a relative path up until the last path separator, -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" stripRelativePath = MP.many (MP.try stripPathComponet)@@ -543,10 +543,10 @@ cabalParse = MP.chunk "haskell-language-server-wrapper-" *> version' -- parses any path component ending with path separator, -- e.g. "foo/"- stripPathComponet = parseUntil1 pathSep *> pathSep+ stripPathComponet = parseUntil1 pathSep *> MP.some pathSep -- parses an absolute path up until the last path separator, -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"- stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)+ stripAbsolutePath = MP.some pathSep *> MP.many (MP.try stripPathComponet) -- parses a relative path up until the last path separator, -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo" stripRelativePath = MP.many (MP.try stripPathComponet)@@ -1265,9 +1265,10 @@ installDestSanityCheck :: ( MonadIO m , MonadCatch m ) =>- FilePath ->+ InstallDirResolved -> Excepts '[DirNotEmpty] m ()-installDestSanityCheck isoDir = do+installDestSanityCheck (IsolateDirResolved isoDir) = do hideErrorDef [doesNotExistErrorType] () $ do contents <- liftIO $ getDirectoryContentsRecursive isoDir unless (null contents) (throwE $ DirNotEmpty isoDir)+installDestSanityCheck _ = pure ()
lib/GHCup/Utils/File/Common.hs view
@@ -109,3 +109,10 @@ checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool checkFileAlreadyExists fp = liftIO $ doesFileExist fp+++mergeFileTree :: [FilePath] -> FilePath -> IO ()+mergeFileTree source dest =+++
lib/GHCup/Utils/Prelude.hs view
@@ -473,7 +473,7 @@ liftIO (moveFile fp dest) `catch` (\e -> if | isDoesNotExistError e -> pure ()- | isPermissionError e {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)+ | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp) | otherwise -> throwIO e) `finally` liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)@@ -515,7 +515,7 @@ let dest = tmp </> takeFileName fp liftIO (moveFile fp dest) `catch`- (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)+ (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e) `finally` liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) | otherwise = liftIO $ removeFile fp