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

More cross fixes to install bindist

Browse Source
This commit is contained in:
Julian Ospald 2023-07-07 16:41:58 +08:00
parent 4361ef7a72
commit a43fa7d63e
No known key found for this signature in database
GPG Key ID: CCC85C0E40C06A8C
17 changed files with 163 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
app/ghcup/BrickMain.hs
View File

@ -472,19 +472,19 @@ install' _ (_, ListResult {..}) = do
dirs <- lift getDirs dirs <- lift getDirs
case lTool of case lTool of
GHC -> do GHC -> do
let vi = getVersionInfo lVer GHC dls let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls
liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce) liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce)
Cabal -> do Cabal -> do
let vi = getVersionInfo lVer Cabal dls let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
GHCup -> do GHCup -> do
let vi = snd <$> getLatest dls GHCup let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
HLS -> do HLS -> do
let vi = getVersionInfo lVer HLS dls let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls
liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
Stack -> do Stack -> do
let vi = getVersionInfo lVer Stack dls let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls
liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
) )
>>= \case >>= \case
@ -565,7 +565,7 @@ del' _ (_, ListResult {..}) = do
let run = runE @'[NotInstalled, UninstallFailed] let run = runE @'[NotInstalled, UninstallFailed]
run (do run (do
let vi = getVersionInfo lVer lTool dls let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls
case lTool of case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
Cabal -> liftE $ rmCabalVer lVer $> vi Cabal -> liftE $ rmCabalVer lVer $> vi

49
app/ghcup/GHCup/OptParse/Common.hs
View File

@ -5,6 +5,7 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ViewPatterns #-}
module GHCup.OptParse.Common where module GHCup.OptParse.Common where
@ -693,52 +694,52 @@ fromVersion' :: ( HasLog env
] m (GHCTargetVersion, Maybe VersionInfo) ] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion' SetRecommended tool = do fromVersion' SetRecommended tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool second Just <$> getRecommended dls tool
?? TagNotFound Recommended tool ?? TagNotFound Recommended tool
fromVersion' (SetGHCVersion v) tool = do fromVersion' (SetGHCVersion v) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion v) tool dls let vi = getVersionInfo v tool dls
case pvp $ prettyVer (_tvVersion v) of -- need to be strict here case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
Left _ -> pure (v, vi) Left _ -> pure (v, vi)
Right pvpIn -> Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case
Just (pvp_, vi') -> do Just (pvp_, vi', mt) -> do
v' <- lift $ pvpToVersion pvp_ "" v' <- lift $ pvpToVersion pvp_ ""
when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion (_tvTarget v) v', Just vi') pure (GHCTargetVersion mt v', Just vi')
Nothing -> pure (v, vi) Nothing -> pure (v, vi)
fromVersion' (SetToolVersion v) tool = do fromVersion' (SetToolVersion (mkTVer -> v)) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo v tool dls let vi = getVersionInfo v tool dls
case pvp $ prettyVer v of -- need to be strict here case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
Left _ -> pure (mkTVer v, vi) Left _ -> pure (v, vi)
Right pvpIn -> Right pvpIn ->
lift (getLatestToolFor tool pvpIn dls) >>= \case lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case
Just (pvp_, vi') -> do Just (pvp_, vi', mt) -> do
v' <- lift $ pvpToVersion pvp_ "" v' <- lift $ pvpToVersion pvp_ ""
when (v' /= v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
pure (GHCTargetVersion mempty v', Just vi') pure (GHCTargetVersion mt v', Just vi')
Nothing -> pure (mkTVer v, vi) Nothing -> pure (v, vi)
fromVersion' (SetToolTag Latest) tool = do fromVersion' (SetToolTag Latest) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool
fromVersion' (SetToolDay day) tool = do fromVersion' (SetToolDay day) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> case getByReleaseDay dls tool day of bimap id Just <$> case getByReleaseDay dls tool day of
Left ad -> throwE $ DayNotFound day tool ad Left ad -> throwE $ DayNotFound day tool ad
Right v -> pure v Right v -> pure v
fromVersion' (SetToolTag LatestPrerelease) tool = do fromVersion' (SetToolTag LatestPrerelease) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool bimap id Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool
fromVersion' (SetToolTag LatestNightly) tool = do fromVersion' (SetToolTag LatestNightly) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool bimap id Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool
fromVersion' (SetToolTag Recommended) tool = do fromVersion' (SetToolTag Recommended) tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
fromVersion' (SetToolTag (Base pvp'')) GHC = do fromVersion' (SetToolTag (Base pvp'')) GHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
bimap mkTVer Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC bimap id Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
fromVersion' SetNext tool = do fromVersion' SetNext tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
next <- case tool of next <- case tool of
@ -783,7 +784,7 @@ fromVersion' SetNext tool = do
. sort . sort
$ stacks) ?? NoToolVersionSet tool $ stacks) ?? NoToolVersionSet tool
GHCup -> fail "GHCup cannot be set" GHCup -> fail "GHCup cannot be set"
let vi = getVersionInfo (_tvVersion next) tool dls let vi = getVersionInfo next tool dls
pure (next, vi) pure (next, vi)
fromVersion' (SetToolTag t') tool = fromVersion' (SetToolTag t') tool =
throwE $ TagNotFound t' tool throwE $ TagNotFound t' tool
@ -799,15 +800,15 @@ checkForUpdates :: ( MonadReader env m
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) )
=> m [(Tool, Version)] => m [(Tool, GHCTargetVersion)]
checkForUpdates = do checkForUpdates = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing) lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing)
let latestInstalled tool = (fmap lVer . lastMay . filter (\lr -> lTool lr == tool)) lInstalled let latestInstalled tool = (fmap (\lr -> GHCTargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled
ghcup <- forMM (getLatest dls GHCup) $ \(l, _) -> do ghcup <- forMM (getLatest dls GHCup) $ \(GHCTargetVersion _ l, _) -> do
(Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer
if (l > ghcup_ver) then pure $ Just (GHCup, l) else pure Nothing if (l > ghcup_ver) then pure $ Just (GHCup, mkTVer l) else pure Nothing
otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t -> otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t ->
forMM (getLatest dls t) $ \(l, _) -> do forMM (getLatest dls t) $ \(l, _) -> do

17
app/ghcup/GHCup/OptParse/Compile.hs
View File

@ -77,6 +77,7 @@ data GHCCompileOptions = GHCCompileOptions
, ovewrwiteVer :: Maybe Version , ovewrwiteVer :: Maybe Version
, buildFlavour :: Maybe String , buildFlavour :: Maybe String
, hadrian :: Bool , hadrian :: Bool
, bignum :: Maybe String
, isolateDir :: Maybe FilePath , isolateDir :: Maybe FilePath
} }
@ -271,6 +272,13 @@ ghcCompileOpts =
<*> switch <*> switch
(long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)" (long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
) )
<*> optional
(option
str
(long "bignum" <> metavar "INTEGER_BACKEND" <> help
"Set the integer backend. This value differs between make ('integer-gmp' and 'integer-simple') and hadrian ('gmp' and 'native')"
)
)
<*> optional <*> optional
(option (option
(eitherReader isolateParser) (eitherReader isolateParser)
@ -511,7 +519,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
case targetHLS of case targetHLS of
HLS.SourceDist targetVer -> do HLS.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls let vi = getVersionInfo (mkTVer targetVer) HLS dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg lift $ logInfo msg
lift $ logInfo lift $ logInfo
@ -531,7 +539,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
patches patches
cabalArgs cabalArgs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls let vi = getVersionInfo (mkTVer targetVer) HLS dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
setHLS targetVer SetHLSOnly Nothing setHLS targetVer SetHLSOnly Nothing
pure (vi, targetVer) pure (vi, targetVer)
@ -560,7 +568,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
case targetGhc of case targetGhc of
GHC.SourceDist targetVer -> do GHC.SourceDist targetVer -> do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls let vi = getVersionInfo (mkTVer targetVer) GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ logInfo msg lift $ logInfo msg
lift $ logInfo lift $ logInfo
@ -577,10 +585,11 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
patches patches
addConfArgs addConfArgs
buildFlavour buildFlavour
bignum
hadrian hadrian
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo (_tvVersion targetVer) GHC dls let vi = getVersionInfo targetVer GHC dls
when setCompile $ void $ liftE $ when setCompile $ void $ liftE $
setGHC targetVer SetGHCOnly Nothing setGHC targetVer SetGHCOnly Nothing
pure (vi, targetVer) pure (vi, targetVer)

4
app/ghcup/GHCup/OptParse/Install.hs
View File

@ -324,7 +324,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
Nothing -> runInstGHC s' $ do Nothing -> runInstGHC s' $ do
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBin liftE $ runBothE' (installGHCBin
(_tvVersion v) v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
addConfArgs addConfArgs
@ -336,7 +336,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
(v, vi) <- liftE $ fromVersion instVer GHC (v, vi) <- liftE $ fromVersion instVer GHC
liftE $ runBothE' (installGHCBindist liftE $ runBothE' (installGHCBindist
(DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing) (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing)
(_tvVersion v) v
(maybe GHCupInternal IsolateDir isolateDir) (maybe GHCupInternal IsolateDir isolateDir)
forceInstall forceInstall
addConfArgs addConfArgs

2
app/ghcup/GHCup/OptParse/Prefetch.hs
View File

@ -195,7 +195,7 @@ prefetch prefetchCommand runAppState runLogger =
forM_ pfCacheDir (liftIO . createDirRecursive') forM_ pfCacheDir (liftIO . createDirRecursive')
(v, _) <- liftE $ fromVersion mt GHC (v, _) <- liftE $ fromVersion mt GHC
if pfGHCSrc if pfGHCSrc
then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir then liftE $ fetchGHCSrc v pfCacheDir
else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do
forM_ pfCacheDir (liftIO . createDirRecursive') forM_ pfCacheDir (liftIO . createDirRecursive')

8
app/ghcup/GHCup/OptParse/Rm.hs
View File

@ -170,7 +170,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmGHCVer ghcVer rmGHCVer ghcVer
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo (_tvVersion ghcVer) GHC dls) pure (getVersionInfo ghcVer GHC dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -186,7 +186,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmCabalVer tv rmCabalVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Cabal dls) pure (getVersionInfo (mkTVer tv) Cabal dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -201,7 +201,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmHLSVer tv rmHLSVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv HLS dls) pure (getVersionInfo (mkTVer tv) HLS dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
@ -216,7 +216,7 @@ rm rmCommand runAppState runLogger = case rmCommand of
liftE $ liftE $
rmStackVer tv rmStackVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
pure (getVersionInfo tv Stack dls) pure (getVersionInfo (mkTVer tv) Stack dls)
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do

2
app/ghcup/GHCup/OptParse/Run.hs
View File

@ -360,7 +360,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
Just v -> do Just v -> do
isInstalled <- lift $ checkIfToolInstalled' GHC v isInstalled <- lift $ checkIfToolInstalled' GHC v
unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin
(_tvVersion v) v
GHCupInternal GHCupInternal
False False
[] []

4
app/ghcup/GHCup/OptParse/Test.hs
View File

@ -169,12 +169,12 @@ test testCommand settings getAppState' runLogger = case testCommand of
(case testBindist of (case testBindist of
Nothing -> runTestGHC s' $ do Nothing -> runTestGHC s' $ do
(v, vi) <- liftE $ fromVersion testVer GHC (v, vi) <- liftE $ fromVersion testVer GHC
liftE $ testGHCVer (_tvVersion v) addMakeArgs liftE $ testGHCVer v addMakeArgs
pure vi pure vi
Just uri -> do Just uri -> do
runTestGHC s'{ settings = settings {noVerify = True}} $ do runTestGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion testVer GHC (v, vi) <- liftE $ fromVersion testVer GHC
liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing Nothing) (_tvVersion v) addMakeArgs liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing Nothing) v addMakeArgs
pure vi pure vi
) )
>>= \case >>= \case

10
app/ghcup/Main.hs
View File

@ -249,7 +249,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
case t of case t of
GHCup -> runLogger $ GHCup -> runLogger $
logWarn ("New GHCup version available: " logWarn ("New GHCup version available: "
<> prettyVer l <> tVerToText l
<> ". To upgrade, run 'ghcup upgrade'") <> ". To upgrade, run 'ghcup upgrade'")
_ -> runLogger $ _ -> runLogger $
logWarn ("New " logWarn ("New "
@ -258,7 +258,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
<> "If you want to install this latest version, run 'ghcup install " <> "If you want to install this latest version, run 'ghcup install "
<> T.pack (prettyShow t) <> T.pack (prettyShow t)
<> " " <> " "
<> prettyVer l <> tVerToText l
<> "'") <> "'")
Just _ -> pure () Just _ -> pure ()
@ -332,7 +332,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
, MonadCatch m , MonadCatch m
) )
=> Command => Command
-> (Tool, Version) -> (Tool, GHCTargetVersion)
-> Excepts -> Excepts
'[ TagNotFound '[ TagNotFound
, DayNotFound , DayNotFound
@ -368,7 +368,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
) )
=> Tool => Tool
-> Maybe ToolVersion -> Maybe ToolVersion
-> Version -> GHCTargetVersion
-> Excepts -> Excepts
'[ TagNotFound '[ TagNotFound
, DayNotFound , DayNotFound
@ -377,4 +377,4 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
] m Bool ] m Bool
cmp' tool instVer ver = do cmp' tool instVer ver = do
(v, _) <- liftE $ fromVersion instVer tool (v, _) <- liftE $ fromVersion instVer tool
pure (v == mkTVer ver) pure (v == ver)

4
lib/GHCup.hs
View File

@ -303,7 +303,7 @@ upgradeGHCup mtarget force' fatal = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ logInfo "Upgrading GHCup..." lift $ logInfo "Upgrading GHCup..."
let latestVer = fst (fromJust (getLatest dls GHCup)) let latestVer = _tvVersion $ fst (fromJust (getLatest dls GHCup))
(Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer "" (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""
when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer dli <- liftE $ getDownloadInfo GHCup latestVer
@ -492,7 +492,7 @@ rmOldGHC :: ( MonadReader env m
=> Excepts '[NotInstalled, UninstallFailed] m () => Excepts '[NotInstalled, UninstallFailed] m ()
rmOldGHC = do rmOldGHC = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls let oldGHCs = toListOf (ix GHC % getTagged Old % to fst) dls
ghcs <- lift $ fmap rights getInstalledGHCs ghcs <- lift $ fmap rights getInstalledGHCs
forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc

16
lib/GHCup/Download.hs
View File

@ -271,7 +271,6 @@ getBase uri = do
pure f pure f
getDownloadInfo :: ( MonadReader env m getDownloadInfo :: ( MonadReader env m
, HasPlatformReq env , HasPlatformReq env
, HasGHCupInfo env , HasGHCupInfo env
@ -283,7 +282,20 @@ getDownloadInfo :: ( MonadReader env m
'[NoDownload] '[NoDownload]
m m
DownloadInfo DownloadInfo
getDownloadInfo t v = do getDownloadInfo t v = getDownloadInfo' t (mkTVer v)
getDownloadInfo' :: ( MonadReader env m
, HasPlatformReq env
, HasGHCupInfo env
)
=> Tool
-> GHCTargetVersion
-- ^ tool version
-> Excepts
'[NoDownload]
m
DownloadInfo
getDownloadInfo' t v = do
(PlatformRequest a p mv) <- lift getPlatformReq (PlatformRequest a p mv) <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo

52
lib/GHCup/GHC.hs
View File

@ -105,7 +105,7 @@ testGHCVer :: ( MonadFail m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Version => GHCTargetVersion
-> [T.Text] -> [T.Text]
-> Excepts -> Excepts
'[ DigestError '[ DigestError
@ -145,7 +145,7 @@ testGHCBindist :: ( MonadFail m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> DownloadInfo => DownloadInfo
-> Version -> GHCTargetVersion
-> [T.Text] -> [T.Text]
-> Excepts -> Excepts
'[ DigestError '[ DigestError
@ -182,7 +182,7 @@ testPackedGHC :: ( MonadMask m
) )
=> FilePath -- ^ Path to the packed GHC bindist => FilePath -- ^ Path to the packed GHC bindist
-> Maybe TarDir -- ^ Subdir of the archive -> Maybe TarDir -- ^ Subdir of the archive
-> Version -- ^ The GHC version -> GHCTargetVersion -- ^ The GHC version
-> [T.Text] -- ^ additional make args -> [T.Text] -- ^ additional make args
-> Excepts -> Excepts
'[ ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed ] m () '[ ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed ] m ()
@ -208,19 +208,21 @@ testUnpackedGHC :: ( MonadReader env m
, MonadIO m , MonadIO m
) )
=> GHCupPath -- ^ Path to the unpacked GHC bindist (where the make file resides) => GHCupPath -- ^ Path to the unpacked GHC bindist (where the make file resides)
-> Version -- ^ The GHC version -> GHCTargetVersion -- ^ The GHC version
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
testUnpackedGHC path ver addMakeArgs = do testUnpackedGHC path tver addMakeArgs = do
lift $ logInfo $ "Testing GHC version " <> prettyVer ver <> "!" lift $ logInfo $ "Testing GHC version " <> tVerToText tver <> "!"
ghcDir <- lift $ ghcupGHCDir (mkTVer ver) ghcDir <- lift $ ghcupGHCDir tver
let ghcBinDir = fromGHCupPath ghcDir </> "bin" let ghcBinDir = fromGHCupPath ghcDir </> "bin"
env <- liftIO $ addToPath ghcBinDir False env <- liftIO $ addToPath ghcBinDir False
lEM $ make' (fmap T.unpack addMakeArgs) lEM $ make' (fmap T.unpack addMakeArgs)
(Just $ fromGHCupPath path) (Just $ fromGHCupPath path)
"ghc-test" "ghc-test"
(Just $ ("STAGE1_GHC", "ghc-" <> T.unpack (prettyVer ver)) : env) (Just $ ("STAGE1_GHC", maybe "" (T.unpack . (<> "-")) (_tvTarget tver)
<> "ghc-"
<> T.unpack (prettyVer $ _tvVersion tver)) : env)
pure () pure ()
@ -243,7 +245,7 @@ fetchGHCSrc :: ( MonadFail m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Version => GHCTargetVersion
-> Maybe FilePath -> Maybe FilePath
-> Excepts -> Excepts
'[ DigestError '[ DigestError
@ -283,7 +285,7 @@ installGHCBindist :: ( MonadFail m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> DownloadInfo -- ^ where/how to download => DownloadInfo -- ^ where/how to download
-> Version -- ^ the version to install -> GHCTargetVersion -- ^ the version to install
-> InstallDir -> InstallDir
-> Bool -- ^ Force install -> Bool -- ^ Force install
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
@ -306,10 +308,8 @@ installGHCBindist :: ( MonadFail m
] ]
m m
() ()
installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do installGHCBindist dlinfo tver installDir forceInstall addConfArgs = do
let tver = mkTVer ver lift $ logDebug $ "Requested to install GHC with " <> tVerToText tver
lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
regularGHCInstalled <- lift $ ghcInstalled tver regularGHCInstalled <- lift $ ghcInstalled tver
@ -317,7 +317,7 @@ installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do
| not forceInstall | not forceInstall
, regularGHCInstalled , regularGHCInstalled
, GHCupInternal <- installDir -> do , GHCupInternal <- installDir -> do
throwE $ AlreadyInstalled GHC ver throwE $ AlreadyInstalled GHC (_tvVersion tver)
| forceInstall | forceInstall
, regularGHCInstalled , regularGHCInstalled
@ -451,7 +451,7 @@ installUnpackedGHC path inst tver forceInstall addConfArgs
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh" lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> fromInstallDir inst) ("./configure" : ("--prefix=" <> fromInstallDir inst)
: (ldOverride <> (T.unpack <$> addConfArgs)) : (maybe mempty (\x -> ["--target=" <> T.unpack x]) (_tvTarget tver) <> ldOverride <> (T.unpack <$> addConfArgs))
) )
(Just $ fromGHCupPath path) (Just $ fromGHCupPath path)
"ghc-configure" "ghc-configure"
@ -489,7 +489,7 @@ installGHCBin :: ( MonadFail m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Version -- ^ the version to install => GHCTargetVersion -- ^ the version to install
-> InstallDir -> InstallDir
-> Bool -- ^ force install -> Bool -- ^ force install
-> [T.Text] -- ^ additional configure args for bindist -> [T.Text] -- ^ additional configure args for bindist
@ -512,9 +512,9 @@ installGHCBin :: ( MonadFail m
] ]
m m
() ()
installGHCBin ver installDir forceInstall addConfArgs = do installGHCBin tver installDir forceInstall addConfArgs = do
dlinfo <- liftE $ getDownloadInfo GHC ver dlinfo <- liftE $ getDownloadInfo' GHC tver
liftE $ installGHCBindist dlinfo ver installDir forceInstall addConfArgs liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs
@ -764,6 +764,7 @@ compileGHC :: ( MonadMask m
-> Maybe (Either FilePath [URI]) -- ^ patches -> Maybe (Either FilePath [URI]) -- ^ patches
-> [Text] -- ^ additional args to ./configure -> [Text] -- ^ additional args to ./configure
-> Maybe String -- ^ build flavour -> Maybe String -- ^ build flavour
-> Maybe String -- ^ bignum
-> Bool -> Bool
-> InstallDir -> InstallDir
-> Excepts -> Excepts
@ -793,7 +794,7 @@ compileGHC :: ( MonadMask m
] ]
m m
GHCTargetVersion GHCTargetVersion
compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs buildFlavour bignum hadrian installDir
= do = do
PlatformRequest { .. } <- lift getPlatformReq PlatformRequest { .. } <- lift getPlatformReq
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@ -805,7 +806,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
-- download source tarball -- download source tarball
dlInfo <- dlInfo <-
preview (ix GHC % ix ver % viSourceDL % _Just) dls preview (ix GHC % ix (mkTVer ver) % viSourceDL % _Just) dls
?? NoDownload ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
@ -1023,6 +1024,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
lEM $ execWithGhcEnv hadrian_build lEM $ execWithGhcEnv hadrian_build
( maybe [] (\j -> ["-j" <> show j] ) jobs ( maybe [] (\j -> ["-j" <> show j] ) jobs
++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour
++ maybe [] (\bn -> ["--bignum=" <> bn]) bignum
++ ["binary-dist"] ++ ["binary-dist"]
) )
(Just workdir) "ghc-make" (Just workdir) "ghc-make"
@ -1081,7 +1083,7 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
(FileDoesNotExistError bc) (FileDoesNotExistError bc)
(liftIO $ copyFile bc (build_mk workdir) False) (liftIO $ copyFile bc (build_mk workdir) False)
Nothing -> Nothing ->
liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf) liftIO $ T.writeFile (build_mk workdir) (addBigNumToConf $ addBuildFlavourToConf defaultConf)
liftE $ checkBuildConfig (build_mk workdir) liftE $ checkBuildConfig (build_mk workdir)
@ -1179,6 +1181,10 @@ compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs build
Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc
Nothing -> bc Nothing -> bc
addBigNumToConf bc = case bignum of
Just bn -> bc <> "\nINTEGER_LIBRARY = " <> T.pack bn
Nothing -> bc
isCross :: GHCTargetVersion -> Bool isCross :: GHCTargetVersion -> Bool
isCross = isJust . _tvTarget isCross = isJust . _tvTarget

2
lib/GHCup/HLS.hs
View File

@ -369,7 +369,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda
-- download source tarball -- download source tarball
dlInfo <- dlInfo <-
preview (ix HLS % ix tver % viSourceDL % _Just) dls preview (ix HLS % ix (mkTVer tver) % viSourceDL % _Just) dls
?? NoDownload ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing

36
lib/GHCup/List.hs
View File

@ -86,7 +86,7 @@ data ListResult = ListResult
-- | Extract all available tool versions and their tags. -- | Extract all available tool versions and their tags.
availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo availableToolVersions :: GHCupDownloads -> Tool -> Map.Map GHCTargetVersion VersionInfo
availableToolVersions av tool = view availableToolVersions av tool = view
(at tool % non Map.empty) (at tool % non Map.empty)
av av
@ -134,13 +134,13 @@ listVersions lt' criteria hideOld showNightly days = do
slr <- strayGHCs avTools slr <- strayGHCs avTools
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
Cabal -> do Cabal -> do
slr <- strayCabals avTools cSet cabals slr <- strayCabals (Map.mapKeys _tvVersion avTools) cSet cabals
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
HLS -> do HLS -> do
slr <- strayHLS avTools hlsSet' hlses slr <- strayHLS (Map.mapKeys _tvVersion avTools) hlsSet' hlses
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
Stack -> do Stack -> do
slr <- strayStacks avTools sSet stacks slr <- strayStacks (Map.mapKeys _tvVersion avTools) sSet stacks
pure (sort (slr ++ lr)) pure (sort (slr ++ lr))
GHCup -> do GHCup -> do
let cg = maybeToList $ currentGHCup avTools let cg = maybeToList $ currentGHCup avTools
@ -159,13 +159,13 @@ listVersions lt' criteria hideOld showNightly days = do
, HasLog env , HasLog env
, MonadIO m , MonadIO m
) )
=> Map.Map Version VersionInfo => Map.Map GHCTargetVersion VersionInfo
-> m [ListResult] -> m [ListResult]
strayGHCs avTools = do strayGHCs avTools = do
ghcs <- getInstalledGHCs ghcs <- getInstalledGHCs
fmap catMaybes $ forM ghcs $ \case fmap catMaybes $ forM ghcs $ \case
Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do
case Map.lookup _tvVersion avTools of case Map.lookup tver avTools of
Just _ -> pure Nothing Just _ -> pure Nothing
Nothing -> do Nothing -> do
lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing
@ -177,7 +177,7 @@ listVersions lt' criteria hideOld showNightly days = do
, lCross = Nothing , lCross = Nothing
, lTag = [] , lTag = []
, lInstalled = True , lInstalled = True
, lStray = isNothing (Map.lookup _tvVersion avTools) , lStray = isNothing (Map.lookup tver avTools)
, lNoBindist = False , lNoBindist = False
, lReleaseDay = Nothing , lReleaseDay = Nothing
, .. , ..
@ -192,7 +192,7 @@ listVersions lt' criteria hideOld showNightly days = do
, lCross = _tvTarget , lCross = _tvTarget
, lTag = [] , lTag = []
, lInstalled = True , lInstalled = True
, lStray = True -- NOTE: cross currently cannot be installed via bindist , lStray = isNothing (Map.lookup tver avTools)
, lNoBindist = False , lNoBindist = False
, lReleaseDay = Nothing , lReleaseDay = Nothing
, .. , ..
@ -309,15 +309,15 @@ listVersions lt' criteria hideOld showNightly days = do
$ "Could not parse version of stray directory" <> T.pack e $ "Could not parse version of stray directory" <> T.pack e
pure Nothing pure Nothing
currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult currentGHCup :: Map.Map GHCTargetVersion VersionInfo -> Maybe ListResult
currentGHCup av = currentGHCup av =
let currentVer = fromJust $ pvpToVersion ghcUpVer "" let currentVer = mkTVer $ fromJust $ pvpToVersion ghcUpVer ""
listVer = Map.lookup currentVer av listVer = Map.lookup currentVer av
latestVer = fst <$> headOf (getTagged Latest) av latestVer = fst <$> headOf (getTagged Latest) av
recommendedVer = fst <$> headOf (getTagged Latest) av recommendedVer = fst <$> headOf (getTagged Latest) av
isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
in if | Map.member currentVer av -> Nothing in if | Map.member currentVer av -> Nothing
| otherwise -> Just $ ListResult { lVer = currentVer | otherwise -> Just $ ListResult { lVer = _tvVersion currentVer
, lTag = maybe (if isOld then [Old] else []) _viTags listVer , lTag = maybe (if isOld then [Old] else []) _viTags listVer
, lCross = Nothing , lCross = Nothing
, lTool = GHCup , lTool = GHCup
@ -346,18 +346,18 @@ listVersions lt' criteria hideOld showNightly days = do
-> [Either FilePath Version] -> [Either FilePath Version]
-> Maybe Version -> Maybe Version
-> [Either FilePath Version] -> [Either FilePath Version]
-> (Version, VersionInfo) -> (GHCTargetVersion, VersionInfo)
-> m ListResult -> m ListResult
toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, VersionInfo{..}) = do toListResult t cSet cabals hlsSet' hlses stackSet' stacks (tver, VersionInfo{..}) = do
let v = _tvVersion tver
case t of case t of
GHC -> do GHC -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver
let tver = mkTVer v lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver)
lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing
lInstalled <- ghcInstalled tver lInstalled <- ghcInstalled tver
fromSrc <- ghcSrcInstalled tver fromSrc <- ghcSrcInstalled tver
hlsPowered <- fmap (elem v) hlsGHCVersions hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions)
pure ListResult { lVer = v, lCross = Nothing , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. } pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. }
Cabal -> do Cabal -> do
lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v
let lSet = cSet == Just v let lSet = cSet == Just v

6
lib/GHCup/Types.hs
View File

@ -104,7 +104,7 @@ instance NFData Requirements
-- | Description of all binary and source downloads. This is a tree -- | Description of all binary and source downloads. This is a tree
-- of nested maps. -- of nested maps.
type GHCupDownloads = Map Tool ToolVersionSpec type GHCupDownloads = Map Tool ToolVersionSpec
type ToolVersionSpec = Map Version VersionInfo type ToolVersionSpec = Map GHCTargetVersion VersionInfo
type ArchitectureSpec = Map Architecture PlatformSpec type ArchitectureSpec = Map Architecture PlatformSpec
type PlatformSpec = Map Platform PlatformVersionSpec type PlatformSpec = Map Platform PlatformVersionSpec
type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo
@ -593,7 +593,9 @@ data GHCTargetVersion = GHCTargetVersion
{ _tvTarget :: Maybe Text { _tvTarget :: Maybe Text
, _tvVersion :: Version , _tvVersion :: Version
} }
deriving (Ord, Eq, Show) deriving (Ord, Eq, Show, GHC.Generic)
instance NFData GHCTargetVersion
data GitBranch = GitBranch data GitBranch = GitBranch
{ ref :: String { ref :: String

18
lib/GHCup/Types/JSON.hs
View File

@ -95,13 +95,29 @@ instance FromJSON URI where
Right x -> pure x Right x -> pure x
Left e -> fail . show $ e Left e -> fail . show $ e
instance ToJSON GHCTargetVersion where
toJSON = toJSON . tVerToText
instance FromJSON GHCTargetVersion where
parseJSON = withText "GHCTargetVersion" $ \t -> case MP.parse ghcTargetVerP "" t of
Right x -> pure x
Left e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e
instance ToJSONKey GHCTargetVersion where
toJSONKey = toJSONKeyText $ \x -> tVerToText x
instance FromJSONKey GHCTargetVersion where
fromJSONKey = FromJSONKeyTextParser $ \t -> case MP.parse ghcTargetVerP "" t of
Right x -> pure x
Left e -> fail $ "Failure in GHCTargetVersion (FromJSONKey)" <> show e
instance ToJSON Versioning where instance ToJSON Versioning where
toJSON = toJSON . prettyV toJSON = toJSON . prettyV
instance FromJSON Versioning where instance FromJSON Versioning where
parseJSON = withText "Versioning" $ \t -> case versioning t of parseJSON = withText "Versioning" $ \t -> case versioning t of
Right x -> pure x Right x -> pure x
Left e -> fail $ "Failure in Version (FromJSON)" <> show e Left e -> fail $ "Failure in GHCTargetVersion (FromJSON)" <> show e
instance ToJSONKey Versioning where instance ToJSONKey Versioning where
toJSONKey = toJSONKeyText $ \x -> prettyV x toJSONKey = toJSONKeyText $ \x -> prettyV x

36
lib/GHCup/Utils.hs
View File

@ -62,7 +62,6 @@ import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
import Data.Char ( isHexDigit ) import Data.Char ( isHexDigit )
import Data.Bifunctor ( first )
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either import Data.Either
import Data.Foldable import Data.Foldable
@ -774,13 +773,16 @@ getGHCForPVP' pvpIn ghcs' mt = do
-- Just (PVP {_pComponents = 8 :| [8,4]}) -- Just (PVP {_pComponents = 8 :| [8,4]})
getLatestToolFor :: MonadThrow m getLatestToolFor :: MonadThrow m
=> Tool => Tool
-> Maybe Text
-> PVP -> PVP
-> GHCupDownloads -> GHCupDownloads
-> m (Maybe (PVP, VersionInfo)) -> m (Maybe (PVP, VersionInfo, Maybe Text))
getLatestToolFor tool pvpIn dls = do getLatestToolFor tool target pvpIn dls = do
let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls let ls :: [(GHCTargetVersion, VersionInfo)]
let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls
pure . fmap (first fst) . headMay . filter (\((v, _), _) -> matchPVPrefix pvpIn v) $ ps let ps :: [((PVP, Text), VersionInfo, Maybe Text)]
ps = catMaybes $ fmap (\(v, vi) -> (,vi, _tvTarget v) <$> versionToPVP (_tvVersion v)) ls
pure . fmap (\((pv', _), vi, mt) -> (pv', vi, mt)) . headMay . filter (\((v, _), _, t) -> matchPVPrefix pvpIn v && t == target) $ ps
@ -885,12 +887,12 @@ intoSubdir bdir tardir = case tardir of
-- | Get the tool version that has this tag. If multiple have it, -- | Get the tool version that has this tag. If multiple have it,
-- picks the greatest version. -- picks the greatest version.
getTagged :: Tag getTagged :: Tag
-> Fold (Map.Map Version VersionInfo) (Version, VersionInfo) -> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getTagged tag = getTagged tag =
to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags)) to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags))
% folding id % folding id
getByReleaseDay :: GHCupDownloads -> Tool -> Day -> Either (Maybe Day) (Version, VersionInfo) getByReleaseDay :: GHCupDownloads -> Tool -> Day -> Either (Maybe Day) (GHCTargetVersion, VersionInfo)
getByReleaseDay av tool day = let mvv = fromMaybe mempty $ headOf (ix tool) av getByReleaseDay av tool day = let mvv = fromMaybe mempty $ headOf (ix tool) av
mdv = Map.foldrWithKey (\k vi@VersionInfo{..} m -> mdv = Map.foldrWithKey (\k vi@VersionInfo{..} m ->
maybe m (\d -> let diff = diffDays d day maybe m (\d -> let diff = diffDays d day
@ -902,24 +904,24 @@ getByReleaseDay av tool day = let mvv = fromMaybe mempty $ headOf (ix tool) av
| absDiff == 0 -> Right (k, vi) | absDiff == 0 -> Right (k, vi)
| otherwise -> Left (Just (addDays diff day)) | otherwise -> Left (Just (addDays diff day))
getByReleaseDayFold :: Day -> Fold (Map.Map Version VersionInfo) (Version, VersionInfo) getByReleaseDayFold :: Day -> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo)
getByReleaseDayFold day = to (Map.toDescList . Map.filter (\VersionInfo {..} -> Just day == _viReleaseDay)) % folding id getByReleaseDayFold day = to (Map.toDescList . Map.filter (\VersionInfo {..} -> Just day == _viReleaseDay)) % folding id
getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatest av tool = headOf (ix tool % getTagged Latest) av getLatest av tool = headOf (ix tool % getTagged Latest) av
getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) getLatestPrerelease :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestPrerelease av tool = headOf (ix tool % getTagged LatestPrerelease) av getLatestPrerelease av tool = headOf (ix tool % getTagged LatestPrerelease) av
getLatestNightly :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) getLatestNightly :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getLatestNightly av tool = headOf (ix tool % getTagged LatestNightly) av getLatestNightly av tool = headOf (ix tool % getTagged LatestNightly) av
getRecommended :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) getRecommended :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo)
getRecommended av tool = headOf (ix tool % getTagged Recommended) 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, VersionInfo) getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (GHCTargetVersion, VersionInfo)
getLatestBaseVersion av pvpVer = getLatestBaseVersion av pvpVer =
headOf (ix GHC % getTagged (Base pvpVer)) av headOf (ix GHC % getTagged (Base pvpVer)) av
@ -1101,9 +1103,9 @@ darwinNotarization _ _ = pure $ Right ()
getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI getChangeLog :: GHCupDownloads -> Tool -> ToolVersion -> Maybe URI
getChangeLog dls tool (GHCVersion (_tvVersion -> v')) = getChangeLog dls tool (GHCVersion v') =
preview (ix tool % ix v' % viChangeLog % _Just) dls preview (ix tool % ix v' % viChangeLog % _Just) dls
getChangeLog dls tool (ToolVersion v') = getChangeLog dls tool (ToolVersion (mkTVer -> v')) =
preview (ix tool % ix v' % viChangeLog % _Just) dls preview (ix tool % ix v' % viChangeLog % _Just) dls
getChangeLog dls tool (ToolTag tag) = getChangeLog dls tool (ToolTag tag) =
preview (ix tool % pre (getTagged tag) % to snd % viChangeLog % _Just) dls preview (ix tool % pre (getTagged tag) % to snd % viChangeLog % _Just) dls
@ -1192,7 +1194,7 @@ rmBDir dir = withRunInIO (\run -> run $
$ rmPathForcibly dir) $ rmPathForcibly dir)
getVersionInfo :: Version getVersionInfo :: GHCTargetVersion
-> Tool -> Tool
-> GHCupDownloads -> GHCupDownloads
-> Maybe VersionInfo -> Maybe VersionInfo