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

Merge branch 'PR/issue-104'

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

126
app/ghcup/Main.hs
View File

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

27931
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
AppState {dirs = Dirs {..}} <- lift ask
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
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
tmp <- lift withGHCupTmpDir

4
lib/GHCup/Errors.hs
View File

@ -67,6 +67,10 @@ data CopyError = CopyError String
data TagNotFound = TagNotFound Tag Tool
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.
data AlreadyInstalled = AlreadyInstalled Tool Version
deriving Show

12
lib/GHCup/Types.hs
View File

@ -85,10 +85,14 @@ data Tool = GHC
-- | All necessary information of a tool version, including
-- source download and per-architecture downloads.
data VersionInfo = VersionInfo
{ _viTags :: [Tag] -- ^ version specific tag
, _viChangeLog :: Maybe URI
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
{ _viTags :: [Tag] -- ^ version specific tag
, _viChangeLog :: Maybe URI
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
-- informative messages
, _viPostInstall :: Maybe Text
, _viPostRemove :: Maybe Text
, _viPreCompile :: Maybe Text
}
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
-> Int -- ^ minor version component
-> GHCupDownloads
-> Maybe Version
-> Maybe (Version, VersionInfo)
getLatestGHCFor major' minor' dls = do
join
. fmap (lastMay . filter (\v -> matchMajor v major' minor'))
. preview (ix GHC % to Map.keys)
. fmap (lastMay . filter (\(v, _) -> matchMajor v major' minor'))
. preview (ix GHC % to Map.toDescList)
$ dls
@ -596,17 +596,17 @@ getTagged tag =
% _head
)
getLatest :: GHCupDownloads -> Tool -> Maybe Version
getLatest av tool = headOf (ix tool % getTagged Latest % to fst) $ av
getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getLatest av tool = headOf (ix tool % getTagged Latest) $ av
getRecommended :: GHCupDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf (ix tool % getTagged Recommended % to fst) $ av
getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo)
getRecommended av tool = headOf (ix tool % getTagged Recommended) $ av
-- | Gets the latest GHC with a given base version.
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe Version
getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (Version, VersionInfo)
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
getVersionInfo :: Version
-> Tool
-> GHCupDownloads
-> Maybe VersionInfo
getVersionInfo v' tool dls =
headOf
( ix tool
% to (Map.filterWithKey (\k _ -> k == v'))
% to Map.elems
% _head
)
dls