Merge branch 'sunday-improvements'

2023-11-12 22:50:09 +08:00 · 2023-11-12 22:50:09 +08:00 · 0103e2771e
parent b6246734e4 e5a7a2da70
commit 0103e2771e
8 changed files with 96 additions and 39 deletions
--- a/app/ghcup/BrickMain.hs
+++ b/app/ghcup/BrickMain.hs
@ -555,7 +555,35 @@ set' bs input@(_, ListResult {..}) = do

  let run =
        flip runReaderT settings
-          . runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
+          . runResourceT
+          . runE
+            @'[ AlreadyInstalled
+              , ArchiveResult
+              , UnknownArchive
+              , FileDoesNotExistError
+              , CopyError
+              , NoDownload
+              , NotInstalled
+              , BuildFailed
+              , TagNotFound
+              , DigestError
+              , ContentLengthError
+              , GPGError
+              , DownloadFailed
+              , DirNotEmpty
+              , NoUpdate
+              , TarDirDoesNotExist
+              , FileAlreadyExistsError
+              , ProcessError
+              , ToolShadowed
+              , UninstallFailed
+              , MergeFileTreeError
+              , NoCompatiblePlatform
+              , GHCup.Errors.ParseError
+              , UnsupportedSetupCombo
+              , DistroNotFound
+              , NoCompatibleArch
+              ]

  run (do
      case lTool of
@ -563,7 +591,12 @@ set' bs input@(_, ListResult {..}) = do
        Cabal -> liftE $ setCabal lVer $> ()
        HLS   -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
        Stack -> liftE $ setStack lVer $> ()
-        GHCup -> pure ()
+        GHCup -> do
+          promptAnswer <- getUserPromptResponse "Switching GHCup versions is not supported.\nDo you want to install the latest version? [Y/N]: "
+          case promptAnswer of
+                PromptYes -> do
+                  void $ liftE $ upgradeGHCup Nothing False False
+                PromptNo -> pure ()
    )
    >>= \case
          VRight _ -> pure $ Right ()
--- a/lib-opt/GHCup/OptParse/Config.hs
+++ b/lib-opt/GHCup/OptParse/Config.hs
@ -67,7 +67,6 @@ configP = subparser
      <> command "show" showP
      <> command "add-release-channel" addP
      )
-    <|> argsP -- add show for a single option
    <|> pure ShowConfig
 where
  initP = info (pure InitConfig) (progDesc "Write default config to ~/.ghcup/config.yaml")
@ -193,10 +192,14 @@ config configCommand settings userConf keybindings runLogger = case configComman
          throwE $ ParseError "Empty values are not allowed"
        Nothing -> do
          usersettings <- decodeSettings k
+          when (usersettings == defaultUserSettings)
+            $ throwE $ ParseError ("Failed to parse setting (maybe typo?): " <> k)
          lift $ doConfig usersettings
          pure ()
        Just v -> do
          usersettings <- decodeSettings (k <> ": " <> v <> "\n")
+          when (usersettings == defaultUserSettings)
+            $ throwE $ ParseError ("Failed to parse key '" <> k <> "' with value '" <> v <> "' as user setting. Maybe typo?")
          lift $ doConfig usersettings
          pure ()
    case r of
@ -204,7 +207,9 @@ config configCommand settings userConf keybindings runLogger = case configComman
      VLeft (V (JSONDecodeError e)) -> do
        runLogger $ logError $ "Error decoding config: " <> T.pack e
        pure $ ExitFailure 65
-      VLeft _ -> pure $ ExitFailure 65
+      VLeft e -> do
+        runLogger (logError $ T.pack $ prettyHFError e)
+        pure $ ExitFailure 65

  AddReleaseChannel force new -> do
    r <- runE @'[DuplicateReleaseChannel] $ do
--- a/lib-opt/GHCup/OptParse/Prefetch.hs
+++ b/lib-opt/GHCup/OptParse/Prefetch.hs
@ -199,19 +199,19 @@ prefetch prefetchCommand runAppState runLogger =
          (v, _) <- liftE $ fromVersion mt GHC
          if pfGHCSrc
          then liftE $ fetchGHCSrc v pfCacheDir
-          else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
+          else liftE $ fetchToolBindist v GHC pfCacheDir
      PrefetchCabal PrefetchOptions {pfCacheDir} mt   -> do
        forM_ pfCacheDir (liftIO . createDirRecursive')
        (v, _) <- liftE $ fromVersion mt Cabal
-        liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir
+        liftE $ fetchToolBindist v Cabal pfCacheDir
      PrefetchHLS PrefetchOptions {pfCacheDir} mt   -> do
        forM_ pfCacheDir (liftIO . createDirRecursive')
        (v, _) <- liftE $ fromVersion mt HLS
-        liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir
+        liftE $ fetchToolBindist v HLS pfCacheDir
      PrefetchStack PrefetchOptions {pfCacheDir} mt   -> do
        forM_ pfCacheDir (liftIO . createDirRecursive')
        (v, _) <- liftE $ fromVersion mt Stack
-        liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
+        liftE $ fetchToolBindist v Stack pfCacheDir
      PrefetchMetadata -> do
        pfreq <- lift getPlatformReq
        _ <- liftE $ getDownloadsF pfreq
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -100,7 +100,7 @@ fetchToolBindist :: ( MonadFail m
                    , MonadIO m
                    , MonadUnliftIO m
                    )
-                 => Version
+                 => GHCTargetVersion
                 -> Tool
                 -> Maybe FilePath
                 -> Excepts
@ -113,7 +113,7 @@ fetchToolBindist :: ( MonadFail m
                      m
                      FilePath
 fetchToolBindist v t mfp = do
-  dlinfo <- liftE $ getDownloadInfo t v
+  dlinfo <- liftE $ getDownloadInfo' t v
  liftE $ downloadCached' dlinfo Nothing mfp


--- a/lib/GHCup/Download.hs
+++ b/lib/GHCup/Download.hs
@ -149,12 +149,16 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
      -> Excepts
           '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError]
           m (Either GHCupInfo Stack.SetupInfo)
-  dl' NewGHCupURL       = fmap Left $ liftE $ getBase @GHCupInfo ghcupURL
-  dl' NewStackSetupURL  = fmap Right $ liftE $ getBase @Stack.SetupInfo stackSetupURL
+  dl' NewGHCupURL       = fmap Left $ liftE (getBase ghcupURL) >>= liftE . decodeMetadata @GHCupInfo
+  dl' NewStackSetupURL  = fmap Right $ liftE (getBase stackSetupURL) >>= liftE . decodeMetadata @Stack.SetupInfo
  dl' (NewGHCupInfo gi) = pure (Left gi)
  dl' (NewSetupInfo si) = pure (Right si)
-  dl' (NewURI uri)      = catchE @JSONError (\(JSONDecodeError _) -> Right <$> getBase @Stack.SetupInfo uri)
-                            $ fmap Left $ getBase @GHCupInfo uri
+  dl' (NewURI uri)      = do
+                            base <- liftE $ getBase uri
+                            catchE @JSONError (\(JSONDecodeError _) -> do
+                                logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: "
+                                Right <$> decodeMetadata @Stack.SetupInfo base)
+                              $ fmap Left $ decodeMetadata @GHCupInfo base

  fromStackSetupInfo :: MonadThrow m
                     => Stack.SetupInfo
@ -201,7 +205,7 @@ etagsFile :: FilePath -> FilePath
 etagsFile = (<.> "etags")


-getBase :: forall j m env . ( MonadReader env m
+getBase :: forall m env . ( MonadReader env m
           , HasDirs env
           , HasSettings env
           , MonadFail m
@ -209,10 +213,9 @@ getBase :: forall j m env . ( MonadReader env m
           , MonadCatch m
           , HasLog env
           , MonadMask m
-           , FromJSON j
           )
        => URI
-        -> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError, JSONError, FileDoesNotExistError] m j
+        -> Excepts '[DownloadFailed, GPGError, DigestError, ContentLengthError] m FilePath
 getBase uri = do
  Settings { noNetwork, downloader, metaMode } <- lift getSettings

@ -232,25 +235,8 @@ getBase uri = do
               $ uri

  -- if we didn't get a filepath from the download, use the cached yaml
-  actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
-  lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
-
-  liftE
-    . onE_ (onError actualYaml)
-    . lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."])
-    . liftIO
-    . Y.decodeFileEither
-    $ actualYaml
+  maybe (lift $ yamlFromCache uri) pure mYaml
 where
-  -- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-  -- may re-download and succeed.
-  onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
-  onError fp = do
-    let efp = etagsFile fp
-    handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
-      (hideError doesNotExistErrorType $ rmFile efp)
-    liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
-
  warnCache :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> Downloader -> m ()
  warnCache s downloader' = do
    let tryDownloder = case downloader' of
@ -322,6 +308,39 @@ getBase uri = do

      pure f

+decodeMetadata :: forall j m env .
+               ( MonadReader env m
+               , HasDirs env
+               , HasSettings env
+               , MonadFail m
+               , MonadIO m
+               , MonadCatch m
+               , HasLog env
+               , MonadMask m
+               , FromJSON j
+               )
+               => FilePath
+               -> Excepts '[JSONError, FileDoesNotExistError] m j
+decodeMetadata actualYaml = do
+  lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
+
+  liftE
+    . onE_ (onError actualYaml)
+    . lEM' @_ @_ @'[JSONError] (\(displayException -> e) -> JSONDecodeError $ unlines [e, "Consider removing " <> actualYaml <> " manually."])
+    . liftIO
+    . Y.decodeFileEither
+    $ actualYaml
+ where
+  -- On error, remove the etags file and set access time to 0. This should ensure the next invocation
+  -- may re-download and succeed.
+  onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
+  onError fp = do
+    let efp = etagsFile fp
+    handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
+      (hideError doesNotExistErrorType $ rmFile efp)
+    liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
+
+
 getDownloadInfo :: ( MonadReader env m
                   , HasPlatformReq env
                   , HasGHCupInfo env
--- a/lib/GHCup/Errors.hs
+++ b/lib/GHCup/Errors.hs
@ -724,7 +724,7 @@ data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), HFErrorPr

 instance Pretty InstallSetError where
  pPrint (InstallSetError reason1 reason2) =
-     text "Both installation and setting the tool failed. Install error was:"
+     text "Both installation and setting the tool failed.\nInstall error was:"
      <+> pPrint reason1
      <+> text "\nSet error was:"
      <+> pPrint reason2
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@ -398,7 +398,7 @@ data UserSettings = UserSettings
  , uPlatformOverride :: Maybe PlatformRequest
  , uMirrors     :: Maybe DownloadMirrors
  }
-  deriving (Show, GHC.Generic)
+  deriving (Show, GHC.Generic, Eq)

 defaultUserSettings :: UserSettings
 defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
@ -459,7 +459,7 @@ data UserKeyBindings = UserKeyBindings
  , kShowAll      :: Maybe KeyCombination
  , kShowAllTools :: Maybe KeyCombination
  }
-  deriving (Show, GHC.Generic)
+  deriving (Show, GHC.Generic, Eq)

 data KeyBindings = KeyBindings
  { bUp              :: KeyCombination
--- a/lib/GHCup/Types/Stack.hs
+++ b/lib/GHCup/Types/Stack.hs
@ -50,7 +50,7 @@ instance FromJSON SetupInfo where
    siSevenzExe <- o .:? "sevenzexe-info"
    siSevenzDll <- o .:? "sevenzdll-info"
    siMsys2     <- o .:? "msys2"          .!= mempty
-    siGHCs      <- o .:? "ghc"            .!= mempty
+    siGHCs      <- o .: "ghc"
    siStack     <- o .:? "stack"          .!= mempty
    pure SetupInfo {..}