hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Allow for dynamic post-install, post-remove and pre-compile msgs

Browse Source
This commit is contained in:
Julian Ospald 2021-02-22 21:55:05 +01:00
parent 38b6c918f9
commit a9b0c0fbc9
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
7 changed files with 19998 additions and 8159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
app/ghcup/BrickMain.hs
View File

@ -16,6 +16,7 @@ import GHCup.Types
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.Prelude hiding ((!?))
import Brick import Brick
import Brick.Widgets.Border import Brick.Widgets.Border
@ -414,17 +415,32 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
, DownloadFailed , DownloadFailed
, NoUpdate , NoUpdate
, TarDirDoesNotExist , TarDirDoesNotExist
, VerNotFound
] ]
(run $ do (run $ do
case lTool of case lTool of
GHC -> liftE $ installGHCBin dls lVer pfreq GHC -> do
Cabal -> liftE $ installCabalBin dls lVer pfreq vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer GHC dls
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> () ?? VerNotFound lVer GHC
HLS -> liftE $ installHLSBin dls lVer pfreq $> () liftE $ installGHCBin dls lVer pfreq $> vi
Cabal -> do
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer Cabal dls
?? VerNotFound lVer Cabal
liftE $ installCabalBin dls lVer pfreq $> vi
GHCup -> do
let vi = fromJust $ snd <$> getLatest dls GHCup
liftE $ upgradeGHCup dls Nothing False pfreq $> vi
HLS -> do
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer HLS dls
?? VerNotFound lVer HLS
liftE $ installHLSBin dls lVer pfreq $> vi
) )
>>= \case >>= \case
VRight _ -> pure $ Right () VRight vi -> do
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V (BuildFailed _ e)) -> VLeft (V (BuildFailed _ e)) ->
pure $ Left [i|Build failed with #{e}|] pure $ Left [i|Build failed with #{e}|]
@ -459,21 +475,34 @@ set' _ (_, ListResult {..}) = do
del' :: BrickState -> (Int, ListResult) -> IO (Either String ()) del' :: BrickState -> (Int, ListResult) -> IO (Either String ())
del' _ (_, ListResult {..}) = do del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger' l <- readIORef logger'
let runLogger = myLoggerT l let runLogger = myLoggerT l
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled] let run = runLogger . flip runReaderT settings . runE @'[NotInstalled, VerNotFound]
(run $ do (run $ do
case lTool of case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> () GHC -> do
Cabal -> liftE $ rmCabalVer lVer $> () vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer Cabal dls
HLS -> liftE $ rmHLSVer lVer $> () ?? VerNotFound lVer Cabal
GHCup -> pure () liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> Just vi
Cabal -> do
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer Cabal dls
?? VerNotFound lVer Cabal
liftE $ rmCabalVer lVer $> Just vi
HLS -> do
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo lVer Cabal dls
?? VerNotFound lVer Cabal
liftE $ rmHLSVer lVer $> Just vi
GHCup -> pure Nothing
) )
>>= \case >>= \case
VRight (Just vi) -> do
forM_ (_viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg
pure $ Right ()
VRight _ -> pure $ Right () VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|] VLeft e -> pure $ Left [i|#{e}|]

126
app/ghcup/Main.hs
View File

@ -32,6 +32,7 @@ import GHCup.Version
#if !defined(TAR) #if !defined(TAR)
import Codec.Archive import Codec.Archive
#endif #endif
import Control.Concurrent
import Control.Exception.Safe import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
@ -1040,6 +1041,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NotInstalled , NotInstalled
, BuildFailed , BuildFailed
, TagNotFound , TagNotFound
, VerNotFound
, DigestError , DigestError
, DownloadFailed , DownloadFailed
, TarDirDoesNotExist , TarDirDoesNotExist
@ -1055,6 +1057,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ FileDoesNotExistError @'[ FileDoesNotExistError
, NotInstalled , NotInstalled
, TagNotFound , TagNotFound
, VerNotFound
] ]
let let
@ -1064,6 +1067,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
, VerNotFound
] ]
let let
@ -1073,12 +1077,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
, VerNotFound
] ]
let runListGHC = runLogger . flip runReaderT appstate let runListGHC = runLogger . flip runReaderT appstate
let runRm = let runRm =
runLogger . flip runReaderT appstate . runE @'[NotInstalled] runLogger . flip runReaderT appstate . runE @'[NotInstalled, VerNotFound]
let runDebugInfo = let runDebugInfo =
runLogger runLogger
@ -1102,6 +1107,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, UnknownArchive , UnknownArchive
, TarDirDoesNotExist , TarDirDoesNotExist
, NotInstalled , NotInstalled
, VerNotFound
#if !defined(TAR) #if !defined(TAR)
, ArchiveResult , ArchiveResult
#endif #endif
@ -1162,20 +1168,24 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installGHC InstallOptions{..} = let installGHC InstallOptions{..} =
(case instBindist of (case instBindist of
Nothing -> runInstTool $ do Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC (v, vi) <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
when instSet $ void $ liftE $ setGHC v SetGHCOnly when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} $ do Just uri -> runInstTool' appstate{ settings = settings {noVerify = True}} $ do
v <- liftE $ fromVersion dls instVer GHC (v, vi) <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBindist liftE $ installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")
(_tvVersion v) (_tvVersion v)
(fromMaybe pfreq instPlatform) (fromMaybe pfreq instPlatform)
when instSet $ void $ liftE $ setGHC v SetGHCOnly when instSet $ void $ liftE $ setGHC v SetGHCOnly
pure vi
) )
>>= \case >>= \case
VRight _ -> do VRight vi -> do
runLogger $ $(logInfo) ("GHC installation successful") runLogger $ $(logInfo) ("GHC installation successful")
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) runLogger $ $(logWarn)
@ -1205,18 +1215,22 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installCabal InstallOptions{..} = let installCabal InstallOptions{..} =
(case instBindist of (case instBindist of
Nothing -> runInstTool $ do Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal (v, vi) <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
v <- liftE $ fromVersion dls instVer Cabal (v, vi) <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBindist liftE $ installCabalBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
(_tvVersion v) (_tvVersion v)
(fromMaybe pfreq instPlatform) (fromMaybe pfreq instPlatform)
pure vi
) )
>>= \case >>= \case
VRight _ -> do VRight vi -> do
runLogger $ $(logInfo) ("Cabal installation successful") runLogger $ $(logInfo) ("Cabal installation successful")
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) runLogger $ $(logWarn)
@ -1238,18 +1252,22 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installHLS InstallOptions{..} = let installHLS InstallOptions{..} =
(case instBindist of (case instBindist of
Nothing -> runInstTool $ do Nothing -> runInstTool $ do
v <- liftE $ fromVersion dls instVer HLS (v, vi) <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) liftE $ installHLSBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
pure vi
Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
v <- liftE $ fromVersion dls instVer HLS (v, vi) <- liftE $ fromVersion dls instVer HLS
liftE $ installHLSBindist liftE $ installHLSBindist
(DownloadInfo uri Nothing "") (DownloadInfo uri Nothing "")
(_tvVersion v) (_tvVersion v)
(fromMaybe pfreq instPlatform) (fromMaybe pfreq instPlatform)
pure vi
) )
>>= \case >>= \case
VRight _ -> do VRight vi -> do
runLogger $ $(logInfo) ("HLS installation successful") runLogger $ $(logInfo) ("HLS installation successful")
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) runLogger $ $(logWarn)
@ -1271,7 +1289,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let setGHC' SetOptions{..} = let setGHC' SetOptions{..} =
(runSetGHC $ do (runSetGHC $ do
v <- liftE $ fromVersion dls sToolVer GHC v <- liftE $ fst <$> fromVersion dls sToolVer GHC
liftE $ setGHC v SetGHCOnly liftE $ setGHC v SetGHCOnly
) )
>>= \case >>= \case
@ -1286,7 +1304,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let setCabal' SetOptions{..} = let setCabal' SetOptions{..} =
(runSetCabal $ do (runSetCabal $ do
v <- liftE $ fromVersion dls sToolVer Cabal v <- liftE $ fst <$> fromVersion dls sToolVer Cabal
liftE $ setCabal (_tvVersion v) liftE $ setCabal (_tvVersion v)
) )
>>= \case >>= \case
@ -1297,7 +1315,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let setHLS' SetOptions{..} = let setHLS' SetOptions{..} =
(runSetHLS $ do (runSetHLS $ do
v <- liftE $ fromVersion dls sToolVer HLS v <- liftE $ fst <$> fromVersion dls sToolVer HLS
liftE $ setHLS (_tvVersion v) liftE $ setHLS (_tvVersion v)
) )
>>= \case >>= \case
@ -1308,30 +1326,51 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let rmGHC' RmOptions{..} = let rmGHC' RmOptions{..} =
(runRm $ do (runRm $ do
liftE $ rmGHCVer ghcVer liftE $
rmGHCVer ghcVer
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo (_tvVersion ghcVer) GHC dls
?? VerNotFound (_tvVersion ghcVer) GHC
pure vi
) )
>>= \case >>= \case
VRight _ -> pure ExitSuccess VRight vi -> do
forM_ (_viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 7 pure $ ExitFailure 7
let rmCabal' tv = let rmCabal' tv =
(runRm $ do (runRm $ do
liftE $ rmCabalVer tv liftE $
rmCabalVer tv
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo tv Cabal dls
?? VerNotFound tv Cabal
pure vi
) )
>>= \case >>= \case
VRight _ -> pure ExitSuccess VRight vi -> do
forM_ (_viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 15 pure $ ExitFailure 15
let rmHLS' tv = let rmHLS' tv =
(runRm $ do (runRm $ do
liftE $ rmHLSVer tv liftE $
rmHLSVer tv
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo tv HLS dls
?? VerNotFound tv HLS
pure vi
) )
>>= \case >>= \case
VRight _ -> pure ExitSuccess VRight vi -> do
forM_ (_viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger ($(logError) [i|#{e}|]) runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 15 pure $ ExitFailure 15
@ -1385,6 +1424,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Compile (CompileGHC GHCCompileOptions {..}) -> Compile (CompileGHC GHCCompileOptions {..}) ->
(runCompileGHC $ do (runCompileGHC $ do
vi <- liftE @_ @'[VerNotFound] $ getVersionInfo targetVer GHC dls
?? VerNotFound targetVer GHC
forM_ (_viPreCompile vi) $ \msg -> do
lift $ $(logInfo) msg
lift $ $(logInfo)
("...waiting for 5 seconds, you can still abort...")
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
liftE $ compileGHC dls liftE $ compileGHC dls
(GHCTargetVersion crossTarget targetVer) (GHCTargetVersion crossTarget targetVer)
bootstrapGhc bootstrapGhc
@ -1393,13 +1439,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
patchDir patchDir
addConfArgs addConfArgs
pfreq pfreq
when setCompile $ void $ liftE when setCompile $ void $ liftE $
$ setGHC (GHCTargetVersion crossTarget targetVer) SetGHCOnly setGHC (GHCTargetVersion crossTarget targetVer) SetGHCOnly
pure vi
) )
>>= \case >>= \case
VRight _ -> do VRight vi -> do
runLogger $ $(logInfo) runLogger $ $(logInfo)
("GHC successfully compiled and installed") ("GHC successfully compiled and installed")
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) runLogger $ $(logWarn)
@ -1429,8 +1478,11 @@ Make sure to clean up #{tmpdir} afterwards.|])
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case (runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
VRight v' -> do VRight v' -> do
let pretty_v = prettyVer v' let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $(logInfo) runLogger $ $(logInfo)
[i|Successfully upgraded GHCup to version #{pretty_v}|] [i|Successfully upgraded GHCup to version #{pretty_v}|]
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
pure ExitSuccess pure ExitSuccess
VLeft (V NoUpdate) -> do VLeft (V NoUpdate) -> do
runLogger $ $(logWarn) [i|No GHCup update available|] runLogger $ $(logWarn) [i|No GHCup update available|]
@ -1506,23 +1558,25 @@ fromVersion :: Monad m
=> GHCupDownloads => GHCupDownloads
-> Maybe ToolVersion -> Maybe ToolVersion
-> Tool -> Tool
-> Excepts '[TagNotFound] m GHCTargetVersion -> Excepts '[TagNotFound, VerNotFound] m (GHCTargetVersion, VersionInfo)
fromVersion av Nothing tool = fromVersion av Nothing tool =
mkTVer <$> getRecommended av tool ?? TagNotFound Recommended tool (\(x, y) -> (mkTVer x, y)) <$> getRecommended av tool
fromVersion av (Just (ToolVersion v)) _ = do ?? TagNotFound Recommended tool
fromVersion av (Just (ToolVersion v)) tool = do
vi <- getVersionInfo (_tvVersion v) tool av ?? VerNotFound (_tvVersion v) tool
case pvp $ prettyVer (_tvVersion v) of case pvp $ prettyVer (_tvVersion v) of
Left _ -> pure v Left _ -> pure (v, vi)
Right (PVP (major' :|[minor'])) -> Right (PVP (major' :|[minor'])) ->
case getLatestGHCFor (fromIntegral major') (fromIntegral minor') av of case getLatestGHCFor (fromIntegral major') (fromIntegral minor') av of
Just v' -> pure $ GHCTargetVersion (_tvTarget v) v' Just (v', vi') -> pure (GHCTargetVersion (_tvTarget v) v', vi')
Nothing -> pure v Nothing -> pure (v, vi)
Right _ -> pure v Right _ -> pure (v, vi)
fromVersion av (Just (ToolTag Latest)) tool = fromVersion av (Just (ToolTag Latest)) tool =
mkTVer <$> getLatest av tool ?? TagNotFound Latest tool (\(x, y) -> (mkTVer x, y)) <$> getLatest av tool ?? TagNotFound Latest tool
fromVersion av (Just (ToolTag Recommended)) tool = fromVersion av (Just (ToolTag Recommended)) tool =
mkTVer <$> getRecommended av tool ?? TagNotFound Recommended tool (\(x, y) -> (mkTVer x, y)) <$> getRecommended av tool ?? TagNotFound Recommended tool
fromVersion av (Just (ToolTag (Base pvp''))) GHC = fromVersion av (Just (ToolTag (Base pvp''))) GHC =
mkTVer <$> getLatestBaseVersion av pvp'' ?? TagNotFound (Base pvp'') GHC (\(x, y) -> (mkTVer x, y)) <$> getLatestBaseVersion av pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion _ (Just (ToolTag t')) tool = fromVersion _ (Just (ToolTag t')) tool =
throwE $ TagNotFound t' tool throwE $ TagNotFound t' tool
@ -1688,27 +1742,27 @@ checkForUpdates :: ( MonadReader AppState m
-> PlatformRequest -> PlatformRequest
-> m () -> m ()
checkForUpdates dls pfreq = do checkForUpdates dls pfreq = do
forM_ (getLatest dls GHCup) $ \l -> do forM_ (getLatest dls GHCup) $ \(l, _) -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver) when (l > ghc_ver)
$ $(logWarn) $ $(logWarn)
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|] [i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
forM_ (getLatest dls GHC) $ \l -> do forM_ (getLatest dls GHC) $ \(l, _) -> do
mghc_ver <- latestInstalled GHC mghc_ver <- latestInstalled GHC
forM mghc_ver $ \ghc_ver -> forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver) when (l > ghc_ver)
$ $(logWarn) $ $(logWarn)
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|] [i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
forM_ (getLatest dls Cabal) $ \l -> do forM_ (getLatest dls Cabal) $ \(l, _) -> do
mcabal_ver <- latestInstalled Cabal mcabal_ver <- latestInstalled Cabal
forM mcabal_ver $ \cabal_ver -> forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver) when (l > cabal_ver)
$ $(logWarn) $ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|] [i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
forM_ (getLatest dls HLS) $ \l -> do forM_ (getLatest dls HLS) $ \(l, _) -> do
mcabal_ver <- latestInstalled HLS mcabal_ver <- latestInstalled HLS
forM mcabal_ver $ \cabal_ver -> forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver) when (l > cabal_ver)

27897
golden/GHCupInfo.json
View File

File diff suppressed because it is too large Load Diff

2
lib/GHCup.hs
View File

@ -1308,7 +1308,7 @@ upgradeGHCup :: ( MonadMask m
upgradeGHCup dls mtarget force pfreq = do upgradeGHCup dls mtarget force pfreq = do
AppState {dirs = Dirs {..}} <- lift ask AppState {dirs = Dirs {..}} <- lift ask
lift $ $(logInfo) [i|Upgrading GHCup...|] lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ getLatest dls GHCup let latestVer = fromJust $ fst <$> getLatest dls GHCup
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir

4
lib/GHCup/Errors.hs
View File

@ -67,6 +67,10 @@ data CopyError = CopyError String
data TagNotFound = TagNotFound Tag Tool data TagNotFound = TagNotFound Tag Tool
deriving Show deriving Show
-- | Unable to find a version of a tool.
data VerNotFound = VerNotFound Version Tool
deriving Show
-- | The tool (such as GHC) is already installed with that version. -- | The tool (such as GHC) is already installed with that version.
data AlreadyInstalled = AlreadyInstalled Tool Version data AlreadyInstalled = AlreadyInstalled Tool Version
deriving Show deriving Show

4
lib/GHCup/Types.hs
View File

@ -89,6 +89,10 @@ data VersionInfo = VersionInfo
, _viChangeLog :: Maybe URI , _viChangeLog :: Maybe URI
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball , _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch , _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
-- informative messages
, _viPostInstall :: Maybe Text
, _viPostRemove :: Maybe Text
, _viPreCompile :: Maybe Text
} }
deriving (Eq, GHC.Generic, Show) deriving (Eq, GHC.Generic, Show)

31
lib/GHCup/Utils.hs
View File

@ -497,11 +497,11 @@ getGHCForMajor major' minor' mt = do
getLatestGHCFor :: Int -- ^ major version component getLatestGHCFor :: Int -- ^ major version component
-> Int -- ^ minor version component -> Int -- ^ minor version component
-> GHCupDownloads -> GHCupDownloads
-> Maybe Version -> Maybe (Version, VersionInfo)
getLatestGHCFor major' minor' dls = do getLatestGHCFor major' minor' dls = do
join join
. fmap (lastMay . filter (\v -> matchMajor v major' minor')) . fmap (lastMay . filter (\(v, _) -> matchMajor v major' minor'))
. preview (ix GHC % to Map.keys) . preview (ix GHC % to Map.toDescList)
$ dls $ dls
@ -596,17 +596,17 @@ getTagged tag =
% _head % _head
) )
getLatest :: GHCupDownloads -> Tool -> Maybe Version getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatest av tool = headOf (ix tool % getTagged Latest % to fst) $ av getLatest av tool = headOf (ix tool % getTagged Latest) $ av
getRecommended :: GHCupDownloads -> Tool -> Maybe Version getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getRecommended av tool = headOf (ix tool % getTagged Recommended % to fst) $ av getRecommended av tool = headOf (ix tool % getTagged Recommended) $ av
-- | Gets the latest GHC with a given base version. -- | Gets the latest GHC with a given base version.
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe Version getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (Version, VersionInfo)
getLatestBaseVersion av pvpVer = getLatestBaseVersion av pvpVer =
headOf (ix GHC % getTagged (Base pvpVer) % to fst) av headOf (ix GHC % getTagged (Base pvpVer)) av
@ -795,3 +795,16 @@ createDirRecursive' p =
_ -> throwIO e _ -> throwIO e
_ -> throwIO e _ -> throwIO e
getVersionInfo :: Version
-> Tool
-> GHCupDownloads
-> Maybe VersionInfo
getVersionInfo v' tool dls =
headOf
( ix tool
% to (Map.filterWithKey (\k _ -> k == v'))
% to Map.elems
% _head
)
dls