Merge branch 'reenable-upgrade'

2022-05-11 16:20:28 +02:00 · 2022-05-11 16:20:28 +02:00 · 0f052c3465
commit 0f052c3465
parent a34d9b7b89 b036c9861f
8 changed files with 73 additions and 59 deletions
--- a/app/ghcup/BrickMain.hs
+++ b/app/ghcup/BrickMain.hs
@ -437,6 +437,7 @@ install' _ (_, ListResult {..}) = do
              , TarDirDoesNotExist
              , FileAlreadyExistsError
              , ProcessError
+              , GHCupShadowed
              ]

  run (do
@ -452,7 +453,7 @@ install' _ (_, ListResult {..}) = do
          liftE $ installCabalBin lVer Nothing 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)
--- a/app/ghcup/GHCup/OptParse.hs
+++ b/app/ghcup/GHCup/OptParse.hs
@ -96,7 +96,7 @@ data Command
  | Config ConfigCommand
  | Whereis WhereisOptions WhereisCommand
 #ifndef DISABLE_UPGRADE
-  | Upgrade UpgradeOpts Bool
+  | Upgrade UpgradeOpts Bool Bool
 #endif
  | ToolRequirements ToolReqOpts
  | ChangeLog ChangeLogOptions
@ -222,18 +222,18 @@ com =
           (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
--- a/app/ghcup/GHCup/OptParse/Upgrade.hs
+++ b/app/ghcup/GHCup/OptParse/Upgrade.hs
@ -65,9 +65,10 @@ 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 @@ type UpgradeEffects = '[ DigestError
                       , FileDoesNotExistError
                       , CopyError
                       , DownloadFailed
+                       , GHCupShadowed
                       ]


@ -120,18 +122,19 @@ upgrade :: ( Monad m
           )
        => 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
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@ -141,9 +141,7 @@ main = do
        )
  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 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             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 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
              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 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
    (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
--- a/docs/guide.md
+++ b/docs/guide.md
@ -57,6 +57,13 @@ as e.g. `/etc/bash_completion.d/ghcup` (depending on distro)
 and make sure your bashrc sources the startup script
 (`/usr/share/bash-completion/bash_completion` on some distros).

+## Portability
+
+`ghcup` is very portable. There are a few exceptions though:
+
+1. `ghcup tui` is only available on non-windows platforms
+2. legacy subcommands `ghcup install` (without a tool identifier) and `ghcup install-cabal` may be removed in the future
+
 # Configuration

 A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
--- a/ghcup.cabal
+++ b/ghcup.cabal
@ -48,13 +48,6 @@ flag no-exe
  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 @@ executable ghcup
    GHCup.OptParse.Set
    GHCup.OptParse.ToolRequirements
    GHCup.OptParse.UnSet
+    GHCup.OptParse.Upgrade
    GHCup.OptParse.Whereis

  hs-source-dirs:     app/ghcup
@ -277,11 +271,6 @@ executable ghcup
  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
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -2587,6 +2587,7 @@ upgradeGHCup :: ( MonadMask m
             => 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,10 +2596,11 @@ upgradeGHCup :: ( MonadMask m
                   , DownloadFailed
                   , NoDownload
                   , NoUpdate
+                   , GHCupShadowed
                   ]
                  m
                  Version
-upgradeGHCup mtarget force' = do
+upgradeGHCup mtarget force' fatal = do
  Dirs {..} <- lift getDirs
  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo

@ -2625,15 +2627,18 @@ upgradeGHCup mtarget force' = do
    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

--- a/lib/GHCup/Errors.hs
+++ b/lib/GHCup/Errors.hs
@ -27,6 +27,7 @@ import           Data.CaseInsensitive           ( CI )
 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 @@ instance Pretty HadrianNotFound where
  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 ]--