Skip to content

Commit

Permalink
Merge branch 'issue-1016'
Browse files Browse the repository at this point in the history
  • Loading branch information
@hasufell
hasufell committed Mar 11, 2024
2 parents b4600b8 + aef10a6 commit 5d0a7b7
Show file tree
Hide file tree
Showing 8 changed files with 21,741 additions and 23,229 deletions.
18 changes: 14 additions & 4 deletions lib-opt/GHCup/OptParse/Compile.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -529,9 +529,14 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
HLS.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (mkTVer targetVer) HLS dls
forM_ (_viPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg
lift $ logInfo
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure ()
Expand Down Expand Up @@ -578,9 +583,14 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
GHC.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (mkTVer targetVer) GHC dls
forM_ (_viPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg
lift $ logInfo
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
_ -> pure ()
Expand Down
41 changes: 41 additions & 0 deletions lib-opt/GHCup/OptParse/Install.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,7 @@ import GHCup.Prelude
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ

import Control.Concurrent (threadDelay)
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
Expand Down Expand Up @@ -327,6 +328,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of
Nothing -> runInstGHC s' $ do
(v, vi) <- liftE $ fromVersion instVer GHC
forM_ (_viPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
liftE $ runBothE' (installGHCBin
v
(maybe GHCupInternal IsolateDir isolateDir)
Expand All @@ -338,6 +344,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
Just uri -> do
runInstGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion instVer GHC
forM_ (_viPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing)
v
Expand Down Expand Up @@ -399,6 +410,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of
Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
forM_ (_viPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
liftE $ runBothE' (installCabalBin
v
(maybe GHCupInternal IsolateDir isolateDir)
Expand All @@ -408,6 +424,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal
forM_ (_viPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
liftE $ runBothE' (installCabalBindist
(DownloadInfo uri Nothing "" Nothing Nothing)
v
Expand Down Expand Up @@ -448,6 +469,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of
Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
forM_ (_viPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
liftE $ runBothE' (installHLSBin
v
(maybe GHCupInternal IsolateDir isolateDir)
Expand All @@ -457,6 +483,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS
forM_ (_viPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
-- TODO: support legacy
liftE $ runBothE' (installHLSBindist
(DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing)
Expand Down Expand Up @@ -498,6 +529,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
(case instBindist of
Nothing -> runInstTool s' $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
forM_ (_viPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
liftE $ runBothE' (installStackBin
v
(maybe GHCupInternal IsolateDir isolateDir)
Expand All @@ -507,6 +543,11 @@ install installCommand settings getAppState' runLogger = case installCommand of
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} $ do
(_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack
forM_ (_viPreInstall =<< vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
liftE $ runBothE' (installStackBindist
(DownloadInfo uri Nothing "" Nothing Nothing)
v
Expand Down
10 changes: 9 additions & 1 deletion lib-opt/GHCup/OptParse/Upgrade.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@ import GHCup.Types
import GHCup.Prelude.File
import GHCup.Prelude.Logger

import Control.Concurrent (threadDelay)
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
Expand Down Expand Up @@ -135,8 +136,15 @@ upgrade uOpts force' fatal Dirs{..} runAppState runLogger = do
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))

runUpgrade runAppState (do
v' <- liftE $ upgradeGHCup target force' fatal
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
Just (tver, vi) <- pure $ getLatest dls GHCup
let latestVer = _tvVersion tver
forM_ (_viPreInstall vi) $ \msg -> do
lift $ logWarn msg
lift $ logWarn
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- give the user a sec to intervene
v' <- liftE $ upgradeGHCup' target force' fatal latestVer
pure (v', dls)
) >>= \case
VRight (v', dls) -> do
Expand Down
42 changes: 39 additions & 3 deletions lib/GHCup.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -273,7 +273,6 @@ getDebugInfo = do
--[ GHCup upgrade etc ]--
-------------------------


-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided.
upgradeGHCup :: ( MonadMask m
Expand Down Expand Up @@ -308,11 +307,48 @@ upgradeGHCup :: ( MonadMask m
m
Version
upgradeGHCup mtarget force' fatal = do
Dirs {..} <- lift getDirs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup))
upgradeGHCup' mtarget force' fatal latestVer


-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,
-- if no path is provided.
upgradeGHCup' :: ( MonadMask m
, MonadReader env m
, HasDirs env
, HasPlatformReq env
, HasGHCupInfo env
, HasSettings env
, MonadCatch m
, HasLog env
, MonadThrow m
, MonadFail m
, MonadResource m
, MonadIO m
, MonadUnliftIO 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
-> Version
-> Excepts
'[ CopyError
, DigestError
, ContentLengthError
, GPGError
, GPGError
, DownloadFailed
, NoDownload
, NoUpdate
, ToolShadowed
]
m
Version
upgradeGHCup' mtarget force' fatal latestVer = do
Dirs {..} <- lift getDirs
lift $ logInfo "Upgrading GHCup..."
let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup))
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer
Expand Down
2 changes: 1 addition & 1 deletion lib/GHCup/Download.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -177,7 +177,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
where
fromDownloadInfo :: DownloadInfo -> VersionInfo
fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing
in VersionInfo [] Nothing Nothing Nothing Nothing aspec Nothing Nothing Nothing Nothing

fromStackDownloadInfo :: MonadThrow m => Stack.GHCDownloadInfo -> m DownloadInfo
fromStackDownloadInfo (Stack.GHCDownloadInfo { gdiDownloadInfo = Stack.DownloadInfo{..} }) = do
Expand Down
1 change: 1 addition & 0 deletions lib/GHCup/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -149,6 +149,7 @@ data VersionInfo = VersionInfo
, _viTestDL :: Maybe DownloadInfo -- ^ test tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
-- informative messages
, _viPreInstall :: Maybe Text
, _viPostInstall :: Maybe Text
, _viPostRemove :: Maybe Text
, _viPreCompile :: Maybe Text
Expand Down
Loading

0 comments on commit 5d0a7b7

Please sign in to comment.