diff --git a/.github/scripts/cabal-cache.sh b/.github/scripts/cabal-cache.sh new file mode 100644 index 0000000..1c2b46d --- /dev/null +++ b/.github/scripts/cabal-cache.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash + +case "$(uname -s)" in + MSYS_*|MINGW*) + ext=".exe" + ;; + *) + ext="" + ;; +esac + +echo "cabal-cache disabled (CABAL_CACHE_DISABLE set)" + diff --git a/.github/scripts/common.sh b/.github/scripts/common.sh index 1801045..262c09b 100644 --- a/.github/scripts/common.sh +++ b/.github/scripts/common.sh @@ -15,7 +15,7 @@ sync_from() { cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store" fi - cabal-cache sync-from-archive \ + cabal-cache.sh sync-from-archive \ --host-name-override=${S3_HOST} \ --host-port-override=443 \ --host-ssl-override=True \ @@ -29,7 +29,7 @@ sync_to() { cabal_store_path="$(dirname "$(cabal help user-config | tail -n 1 | xargs)")/store" fi - cabal-cache sync-to-archive \ + cabal-cache.sh sync-to-archive \ --host-name-override=${S3_HOST} \ --host-port-override=443 \ --host-ssl-override=True \ @@ -115,6 +115,10 @@ download_cabal_cache() { mv "cabal-cache${exe}" "${dest}${exe}" chmod +x "${dest}${exe}" fi + + # install shell wrapper + cp "${CI_PROJECT_DIR}"/.github/scripts/cabal-cache.sh "$HOME"/.local/bin/ + chmod +x "$HOME"/.local/bin/cabal-cache.sh ) } diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index f1c736c..096e572 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -12,6 +12,10 @@ on: schedule: - cron: '0 2 * * *' +env: + CABAL_CACHE_DISABLE: ${{ vars.CABAL_CACHE_DISABLE }} + CABAL_CACHE_NONFATAL: yes + jobs: build-linux: name: Build linux binary diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 711a4fe..e6f8921 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -156,10 +156,10 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..} <+> padLeft (Pad 1) (minHSize 25 $ str "Tags") <+> padLeft (Pad 5) (str "Notes") renderList' bis@BrickInternalState{..} = - let getMinLength = length . intercalate "," . fmap tagToString - minLength = V.maximum $ V.map (getMinLength . lTag) clr - in withDefAttr listAttr . drawListElements (renderItem minLength) True $ bis - renderItem minTagSize _ b listResult@ListResult{lTag = lTag', ..} = + let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) clr + minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) clr + in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis + renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} = let marks = if | lSet -> (withAttr (attrName "set") $ str "✔✔") | lInstalled -> (withAttr (attrName "installed") $ str "✓ ") @@ -184,7 +184,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..} ( minHSize 6 (printTool lTool) ) - <+> minHSize 15 (str ver) + <+> minHSize minVerSize (str ver) <+> (let l = catMaybes . fmap printTag $ sort lTag' in padLeft (Pad 1) $ minHSize minTagSize $ if null l then emptyWidget @@ -472,19 +472,19 @@ install' _ (_, ListResult {..}) = do dirs <- lift getDirs case lTool of GHC -> do - let vi = getVersionInfo lVer GHC dls - liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce) + let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls + liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce) Cabal -> do - let vi = getVersionInfo lVer Cabal dls + let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) GHCup -> do let vi = snd <$> getLatest dls GHCup liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) HLS -> do - let vi = getVersionInfo lVer HLS dls + let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) Stack -> do - let vi = getVersionInfo lVer Stack dls + let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) ) >>= \case @@ -565,7 +565,7 @@ del' _ (_, ListResult {..}) = do let run = runE @'[NotInstalled, UninstallFailed] run (do - let vi = getVersionInfo lVer lTool dls + let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls case lTool of GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi Cabal -> liftE $ rmCabalVer lVer $> vi diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs index ad05c34..37e7c6c 100644 --- a/app/ghcup/GHCup/OptParse/Common.hs +++ b/app/ghcup/GHCup/OptParse/Common.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ViewPatterns #-} module GHCup.OptParse.Common where @@ -693,52 +694,52 @@ fromVersion' :: ( HasLog env ] m (GHCTargetVersion, Maybe VersionInfo) fromVersion' SetRecommended tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap mkTVer Just <$> getRecommended dls tool + second Just <$> getRecommended dls tool ?? TagNotFound Recommended tool fromVersion' (SetGHCVersion v) tool = do 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 Left _ -> pure (v, vi) Right pvpIn -> - lift (getLatestToolFor tool pvpIn dls) >>= \case - Just (pvp_, vi') -> do + lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case + Just (pvp_, vi', mt) -> do v' <- lift $ pvpToVersion pvp_ "" 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) -fromVersion' (SetToolVersion v) tool = do +fromVersion' (SetToolVersion (mkTVer -> v)) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo v tool dls - case pvp $ prettyVer v of -- need to be strict here - Left _ -> pure (mkTVer v, vi) + case pvp $ prettyVer (_tvVersion v) of -- need to be strict here + Left _ -> pure (v, vi) Right pvpIn -> - lift (getLatestToolFor tool pvpIn dls) >>= \case - Just (pvp_, vi') -> do + lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case + Just (pvp_, vi', mt) -> do v' <- lift $ pvpToVersion pvp_ "" - when (v' /= v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') - pure (GHCTargetVersion mempty v', Just vi') - Nothing -> pure (mkTVer v, vi) + when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') + pure (GHCTargetVersion mt v', Just vi') + Nothing -> pure (v, vi) fromVersion' (SetToolTag Latest) tool = do 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 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 Right v -> pure v fromVersion' (SetToolTag LatestPrerelease) tool = do 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 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 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 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 GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo next <- case tool of @@ -783,7 +784,7 @@ fromVersion' SetNext tool = do . sort $ stacks) ?? NoToolVersionSet tool GHCup -> fail "GHCup cannot be set" - let vi = getVersionInfo (_tvVersion next) tool dls + let vi = getVersionInfo next tool dls pure (next, vi) fromVersion' (SetToolTag t') tool = throwE $ TagNotFound t' tool @@ -799,15 +800,15 @@ checkForUpdates :: ( MonadReader env m , MonadIO m , MonadFail m ) - => m [(Tool, Version)] + => m [(Tool, GHCTargetVersion)] checkForUpdates = do GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo 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 - 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 -> forMM (getLatest dls t) $ \(l, _) -> do diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index e10668a..f50fb9d 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -66,7 +66,7 @@ data CompileCommand = CompileGHC GHCCompileOptions data GHCCompileOptions = GHCCompileOptions - { targetGhc :: GHC.GHCVer Version + { targetGhc :: GHC.GHCVer , bootstrapGhc :: Either Version FilePath , jobs :: Maybe Int , buildConfig :: Maybe FilePath @@ -511,7 +511,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do case targetHLS of HLS.SourceDist targetVer -> do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo targetVer HLS dls + let vi = getVersionInfo (mkTVer targetVer) HLS dls forM_ (_viPreCompile =<< vi) $ \msg -> do lift $ logInfo msg lift $ logInfo @@ -531,7 +531,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do patches cabalArgs GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo targetVer HLS dls + let vi = getVersionInfo (mkTVer targetVer) HLS dls when setCompile $ void $ liftE $ setHLS targetVer SetHLSOnly Nothing pure (vi, targetVer) @@ -555,15 +555,12 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do VLeft e -> do runLogger $ logError $ T.pack $ prettyHFError e pure $ ExitFailure 9 - (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do - runLogger $ logError "Hadrian cross compile support is not yet implemented!" - pure $ ExitFailure 9 (CompileGHC GHCCompileOptions {..}) -> runCompileGHC runAppState (do case targetGhc of GHC.SourceDist targetVer -> do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo targetVer GHC dls + let vi = getVersionInfo (mkTVer targetVer) GHC dls forM_ (_viPreCompile =<< vi) $ \msg -> do lift $ logInfo msg lift $ logInfo @@ -571,10 +568,8 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene _ -> pure () targetVer <- liftE $ compileGHC - ((\case - GHC.SourceDist v -> GHC.SourceDist $ GHCTargetVersion crossTarget v - GHC.GitDist g -> GHC.GitDist g - GHC.RemoteDist r -> GHC.RemoteDist r) targetGhc) + targetGhc + crossTarget ovewrwiteVer bootstrapGhc jobs @@ -585,7 +580,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do hadrian (maybe GHCupInternal IsolateDir isolateDir) GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo (_tvVersion targetVer) GHC dls + let vi = getVersionInfo targetVer GHC dls when setCompile $ void $ liftE $ setGHC targetVer SetGHCOnly Nothing pure (vi, targetVer) diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 868828e..e13f740 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -324,7 +324,7 @@ install installCommand settings getAppState' runLogger = case installCommand of Nothing -> runInstGHC s' $ do (v, vi) <- liftE $ fromVersion instVer GHC liftE $ runBothE' (installGHCBin - (_tvVersion v) + v (maybe GHCupInternal IsolateDir isolateDir) forceInstall addConfArgs @@ -336,7 +336,7 @@ install installCommand settings getAppState' runLogger = case installCommand of (v, vi) <- liftE $ fromVersion instVer GHC liftE $ runBothE' (installGHCBindist (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing) - (_tvVersion v) + v (maybe GHCupInternal IsolateDir isolateDir) forceInstall addConfArgs diff --git a/app/ghcup/GHCup/OptParse/Prefetch.hs b/app/ghcup/GHCup/OptParse/Prefetch.hs index 3f4596f..0839dd0 100644 --- a/app/ghcup/GHCup/OptParse/Prefetch.hs +++ b/app/ghcup/GHCup/OptParse/Prefetch.hs @@ -195,7 +195,7 @@ prefetch prefetchCommand runAppState runLogger = forM_ pfCacheDir (liftIO . createDirRecursive') (v, _) <- liftE $ fromVersion mt GHC if pfGHCSrc - then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir + then liftE $ fetchGHCSrc v pfCacheDir else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir PrefetchCabal PrefetchOptions {pfCacheDir} mt -> do forM_ pfCacheDir (liftIO . createDirRecursive') diff --git a/app/ghcup/GHCup/OptParse/Rm.hs b/app/ghcup/GHCup/OptParse/Rm.hs index 615c319..bfacb40 100644 --- a/app/ghcup/GHCup/OptParse/Rm.hs +++ b/app/ghcup/GHCup/OptParse/Rm.hs @@ -170,7 +170,7 @@ rm rmCommand runAppState runLogger = case rmCommand of liftE $ rmGHCVer ghcVer GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - pure (getVersionInfo (_tvVersion ghcVer) GHC dls) + pure (getVersionInfo ghcVer GHC dls) ) >>= \case VRight vi -> do @@ -186,7 +186,7 @@ rm rmCommand runAppState runLogger = case rmCommand of liftE $ rmCabalVer tv GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - pure (getVersionInfo tv Cabal dls) + pure (getVersionInfo (mkTVer tv) Cabal dls) ) >>= \case VRight vi -> do @@ -201,7 +201,7 @@ rm rmCommand runAppState runLogger = case rmCommand of liftE $ rmHLSVer tv GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - pure (getVersionInfo tv HLS dls) + pure (getVersionInfo (mkTVer tv) HLS dls) ) >>= \case VRight vi -> do @@ -216,7 +216,7 @@ rm rmCommand runAppState runLogger = case rmCommand of liftE $ rmStackVer tv GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - pure (getVersionInfo tv Stack dls) + pure (getVersionInfo (mkTVer tv) Stack dls) ) >>= \case VRight vi -> do diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index fb0b0a5..0d9ad03 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -360,7 +360,7 @@ run RunOptions{..} runAppState leanAppstate runLogger = do Just v -> do isInstalled <- lift $ checkIfToolInstalled' GHC v unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin - (_tvVersion v) + v GHCupInternal False [] diff --git a/app/ghcup/GHCup/OptParse/Test.hs b/app/ghcup/GHCup/OptParse/Test.hs index 409f539..bfa3cee 100644 --- a/app/ghcup/GHCup/OptParse/Test.hs +++ b/app/ghcup/GHCup/OptParse/Test.hs @@ -169,12 +169,12 @@ test testCommand settings getAppState' runLogger = case testCommand of (case testBindist of Nothing -> runTestGHC s' $ do (v, vi) <- liftE $ fromVersion testVer GHC - liftE $ testGHCVer (_tvVersion v) addMakeArgs + liftE $ testGHCVer v addMakeArgs pure vi Just uri -> do runTestGHC s'{ settings = settings {noVerify = True}} $ do (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 ) >>= \case diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 8c7ff1f..1d75c20 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -249,7 +249,7 @@ Report bugs at |] case t of GHCup -> runLogger $ logWarn ("New GHCup version available: " - <> prettyVer l + <> tVerToText l <> ". To upgrade, run 'ghcup upgrade'") _ -> runLogger $ logWarn ("New " @@ -258,7 +258,7 @@ Report bugs at |] <> "If you want to install this latest version, run 'ghcup install " <> T.pack (prettyShow t) <> " " - <> prettyVer l + <> tVerToText l <> "'") Just _ -> pure () @@ -332,7 +332,7 @@ Report bugs at |] , MonadCatch m ) => Command - -> (Tool, Version) + -> (Tool, GHCTargetVersion) -> Excepts '[ TagNotFound , DayNotFound @@ -368,7 +368,7 @@ Report bugs at |] ) => Tool -> Maybe ToolVersion - -> Version + -> GHCTargetVersion -> Excepts '[ TagNotFound , DayNotFound @@ -377,4 +377,4 @@ Report bugs at |] ] m Bool cmp' tool instVer ver = do (v, _) <- liftE $ fromVersion instVer tool - pure (v == mkTVer ver) + pure (v == ver) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index a00550f..443f3c5 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -303,7 +303,7 @@ upgradeGHCup mtarget force' fatal = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo lift $ logInfo "Upgrading GHCup..." - let latestVer = fst (fromJust (getLatest dls 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 @@ -492,7 +492,7 @@ rmOldGHC :: ( MonadReader env m => Excepts '[NotInstalled, UninstallFailed] m () rmOldGHC = do 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 forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 71319a3..9b5e549 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -271,7 +271,6 @@ getBase uri = do pure f - getDownloadInfo :: ( MonadReader env m , HasPlatformReq env , HasGHCupInfo env @@ -283,7 +282,20 @@ getDownloadInfo :: ( MonadReader env m '[NoDownload] m 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 GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index aefc1c7..df59031 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -80,9 +80,9 @@ import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP -data GHCVer v = SourceDist v - | GitDist GitBranch - | RemoteDist URI +data GHCVer = SourceDist Version + | GitDist GitBranch + | RemoteDist URI @@ -105,7 +105,7 @@ testGHCVer :: ( MonadFail m , MonadIO m , MonadUnliftIO m ) - => Version + => GHCTargetVersion -> [T.Text] -> Excepts '[ DigestError @@ -145,7 +145,7 @@ testGHCBindist :: ( MonadFail m , MonadUnliftIO m ) => DownloadInfo - -> Version + -> GHCTargetVersion -> [T.Text] -> Excepts '[ DigestError @@ -182,7 +182,7 @@ testPackedGHC :: ( MonadMask m ) => FilePath -- ^ Path to the packed GHC bindist -> Maybe TarDir -- ^ Subdir of the archive - -> Version -- ^ The GHC version + -> GHCTargetVersion -- ^ The GHC version -> [T.Text] -- ^ additional make args -> Excepts '[ ArchiveResult, UnknownArchive, TarDirDoesNotExist, TestFailed ] m () @@ -208,19 +208,21 @@ testUnpackedGHC :: ( MonadReader env m , MonadIO m ) => 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 -> Excepts '[ProcessError] m () -testUnpackedGHC path ver addMakeArgs = do - lift $ logInfo $ "Testing GHC version " <> prettyVer ver <> "!" - ghcDir <- lift $ ghcupGHCDir (mkTVer ver) +testUnpackedGHC path tver addMakeArgs = do + lift $ logInfo $ "Testing GHC version " <> tVerToText tver <> "!" + ghcDir <- lift $ ghcupGHCDir tver let ghcBinDir = fromGHCupPath ghcDir "bin" env <- liftIO $ addToPath ghcBinDir False lEM $ make' (fmap T.unpack addMakeArgs) (Just $ fromGHCupPath path) "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 () @@ -243,7 +245,7 @@ fetchGHCSrc :: ( MonadFail m , MonadIO m , MonadUnliftIO m ) - => Version + => GHCTargetVersion -> Maybe FilePath -> Excepts '[ DigestError @@ -283,7 +285,7 @@ installGHCBindist :: ( MonadFail m , MonadUnliftIO m ) => DownloadInfo -- ^ where/how to download - -> Version -- ^ the version to install + -> GHCTargetVersion -- ^ the version to install -> InstallDir -> Bool -- ^ Force install -> [T.Text] -- ^ additional configure args for bindist @@ -306,10 +308,8 @@ installGHCBindist :: ( MonadFail m ] m () -installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do - let tver = mkTVer ver - - lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver +installGHCBindist dlinfo tver installDir forceInstall addConfArgs = do + lift $ logDebug $ "Requested to install GHC with " <> tVerToText tver regularGHCInstalled <- lift $ ghcInstalled tver @@ -317,7 +317,7 @@ installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do | not forceInstall , regularGHCInstalled , GHCupInternal <- installDir -> do - throwE $ AlreadyInstalled GHC ver + throwE $ AlreadyInstalled GHC (_tvVersion tver) | forceInstall , regularGHCInstalled @@ -336,12 +336,12 @@ installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do case installDir of IsolateDir isoDir -> do -- isolated install lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir - liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall addConfArgs + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) tver forceInstall addConfArgs GHCupInternal -> do -- regular install -- prepare paths ghcdir <- lift $ ghcupGHCDir tver - liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall addConfArgs + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) tver forceInstall addConfArgs -- make symlinks & stuff when regular install, liftE $ postGHCInstall tver @@ -375,7 +375,7 @@ installPackedGHC :: ( MonadMask m => FilePath -- ^ Path to the packed GHC bindist -> Maybe TarDir -- ^ Subdir of the archive -> InstallDirResolved - -> Version -- ^ The GHC version + -> GHCTargetVersion -- ^ The GHC version -> Bool -- ^ Force install -> [T.Text] -- ^ additional configure args for bindist -> Excepts @@ -423,17 +423,17 @@ installUnpackedGHC :: ( MonadReader env m ) => GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides) -> InstallDirResolved -- ^ Path to install to - -> Version -- ^ The GHC version + -> GHCTargetVersion -- ^ The GHC version -> Bool -- ^ Force install -> [T.Text] -- ^ additional configure args for bindist -> Excepts '[ProcessError, MergeFileTreeError] m () -installUnpackedGHC path inst ver forceInstall addConfArgs +installUnpackedGHC path inst tver forceInstall addConfArgs | isWindows = do lift $ logInfo "Installing GHC (this may take a while)" -- Windows bindists are relocatable and don't need -- to run configure. -- We also must make sure to preserve mtime to not confuse ghc-pkg. - liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> do + liftE $ mergeFileTree path inst GHC tver $ \source dest -> do mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source) when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest liftIO $ moveFilePortable source dest @@ -442,7 +442,7 @@ installUnpackedGHC path inst ver forceInstall addConfArgs PlatformRequest {..} <- lift getPlatformReq let ldOverride - | ver >= [vver|8.2.2|] + | _tvVersion tver >= [vver|8.2.2|] , _rPlatform `elem` [Linux Alpine, Darwin] = ["--disable-ld-override"] | otherwise @@ -451,7 +451,7 @@ installUnpackedGHC path inst ver forceInstall addConfArgs lift $ logInfo "Installing GHC (this may take a while)" lEM $ execLogged "sh" ("./configure" : ("--prefix=" <> fromInstallDir inst) - : (ldOverride <> (T.unpack <$> addConfArgs)) + : (maybe mempty (\x -> ["--target=" <> T.unpack x]) (_tvTarget tver) <> ldOverride <> (T.unpack <$> addConfArgs)) ) (Just $ fromGHCupPath path) "ghc-configure" @@ -462,7 +462,7 @@ installUnpackedGHC path inst ver forceInstall addConfArgs liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) inst GHC - (mkTVer ver) + tver (\f t -> liftIO $ do mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) install f t (not forceInstall) @@ -489,7 +489,7 @@ installGHCBin :: ( MonadFail m , MonadIO m , MonadUnliftIO m ) - => Version -- ^ the version to install + => GHCTargetVersion -- ^ the version to install -> InstallDir -> Bool -- ^ force install -> [T.Text] -- ^ additional configure args for bindist @@ -512,9 +512,9 @@ installGHCBin :: ( MonadFail m ] m () -installGHCBin ver installDir forceInstall addConfArgs = do - dlinfo <- liftE $ getDownloadInfo GHC ver - liftE $ installGHCBindist dlinfo ver installDir forceInstall addConfArgs +installGHCBin tver installDir forceInstall addConfArgs = do + dlinfo <- liftE $ getDownloadInfo' GHC tver + liftE $ installGHCBindist dlinfo tver installDir forceInstall addConfArgs @@ -755,7 +755,8 @@ compileGHC :: ( MonadMask m , MonadUnliftIO m , MonadFail m ) - => GHCVer GHCTargetVersion + => GHCVer + -> Maybe Text -- ^ cross target -> Maybe Version -- ^ overwrite version -> Either Version FilePath -- ^ version to bootstrap with -> Maybe Int -- ^ jobs @@ -792,19 +793,19 @@ compileGHC :: ( MonadMask m ] m GHCTargetVersion -compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir +compileGHC targetGhc crossTarget ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir = do PlatformRequest { .. } <- lift getPlatformReq GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo (workdir, tmpUnpack, tver) <- case targetGhc of -- unpack from version tarball - SourceDist tver -> do - lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap + SourceDist ver -> do + lift $ logDebug $ "Requested to compile: " <> prettyVer ver <> " with " <> either prettyVer T.pack bstrap -- download source tarball dlInfo <- - preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls + preview (ix GHC % ix (mkTVer ver) % viSourceDL % _Just) dls ?? NoDownload dl <- liftE $ downloadCached dlInfo Nothing @@ -818,7 +819,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr (view dlSubdir dlInfo) liftE $ applyAnyPatch patches (fromGHCupPath workdir) - pure (workdir, tmpUnpack, Just tver) + pure (workdir, tmpUnpack, Just (GHCTargetVersion crossTarget ver)) RemoteDist uri -> do lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri) @@ -842,7 +843,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr let workdir = appendGHCupPath tmpUnpack (takeDirectory bf) - pure (workdir, tmpUnpack, mkTVer <$> tver) + pure (workdir, tmpUnpack, GHCTargetVersion crossTarget <$> tver) -- clone from git GitDist GitBranch{..} -> do @@ -899,10 +900,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr pure tver - pure (tmpUnpack, tmpUnpack, mkTVer <$> tver) + pure (tmpUnpack, tmpUnpack, GHCTargetVersion crossTarget <$> tver) -- the version that's installed may differ from the -- compiled version, so the user can overwrite it - installVer <- if | Just ov' <- ov -> pure (mkTVer ov') + installVer <- if | Just ov' <- ov -> pure (GHCTargetVersion crossTarget ov') | Just tver' <- tver -> pure tver' | otherwise -> fail "Newer GHCs don't support discovering the version in git. Complain to GHC devs: https://gitlab.haskell.org/ghc/ghc/-/issues/22322" @@ -948,7 +949,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr liftE $ installPackedGHC bindist (Just $ RegexDir "ghc-.*") ghcdir - (installVer ^. tvVersion) + installVer False -- not a force install, since we already overwrite when compiling. [] @@ -987,9 +988,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr defaultConf = let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) - in case targetGhc of - SourceDist (GHCTargetVersion (Just _) _) -> cross_mk - _ -> default_mk + in case crossTarget of + Just _ -> cross_mk + _ -> default_mk compileHadrianBindist :: ( MonadReader env m , HasDirs env @@ -1015,8 +1016,6 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr m (Maybe FilePath) -- ^ output path of bindist, None for cross compileHadrianBindist tver workdir ghcdir = do - lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap" - liftE $ configureBindist tver workdir ghcdir lift $ logInfo "Building (this may take a while)..." @@ -1164,8 +1163,8 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadr let lines' = fmap T.strip . T.lines $ decUTF8Safe c -- for cross, we need Stage1Only - case targetGhc of - SourceDist (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE + case crossTarget of + Just _ -> when ("Stage1Only = YES" `notElem` lines') $ throwE (InvalidBuildConfig [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] ) diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs index 8d39478..744ba54 100644 --- a/lib/GHCup/HLS.hs +++ b/lib/GHCup/HLS.hs @@ -369,7 +369,7 @@ compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal upda -- download source tarball dlInfo <- - preview (ix HLS % ix tver % viSourceDL % _Just) dls + preview (ix HLS % ix (mkTVer tver) % viSourceDL % _Just) dls ?? NoDownload dl <- liftE $ downloadCached dlInfo Nothing diff --git a/lib/GHCup/List.hs b/lib/GHCup/List.hs index 4acf01d..3d38880 100644 --- a/lib/GHCup/List.hs +++ b/lib/GHCup/List.hs @@ -86,7 +86,7 @@ data ListResult = ListResult -- | 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 (at tool % non Map.empty) av @@ -134,13 +134,13 @@ listVersions lt' criteria hideOld showNightly days = do slr <- strayGHCs avTools pure (sort (slr ++ lr)) Cabal -> do - slr <- strayCabals avTools cSet cabals + slr <- strayCabals (Map.mapKeys _tvVersion avTools) cSet cabals pure (sort (slr ++ lr)) HLS -> do - slr <- strayHLS avTools hlsSet' hlses + slr <- strayHLS (Map.mapKeys _tvVersion avTools) hlsSet' hlses pure (sort (slr ++ lr)) Stack -> do - slr <- strayStacks avTools sSet stacks + slr <- strayStacks (Map.mapKeys _tvVersion avTools) sSet stacks pure (sort (slr ++ lr)) GHCup -> do let cg = maybeToList $ currentGHCup avTools @@ -159,44 +159,29 @@ listVersions lt' criteria hideOld showNightly days = do , HasLog env , MonadIO m ) - => Map.Map Version VersionInfo + => Map.Map GHCTargetVersion VersionInfo -> m [ListResult] strayGHCs avTools = do ghcs <- getInstalledGHCs fmap catMaybes $ forM ghcs $ \case - Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do - case Map.lookup _tvVersion avTools of + Right tver@GHCTargetVersion{ .. } -> do + case Map.lookup tver avTools of Just _ -> pure Nothing Nothing -> do - lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing + lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget fromSrc <- ghcSrcInstalled tver hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions pure $ Just $ ListResult { lTool = GHC , lVer = _tvVersion - , lCross = Nothing + , lCross = _tvTarget , lTag = [] , lInstalled = True - , lStray = isNothing (Map.lookup _tvVersion avTools) + , lStray = isNothing (Map.lookup tver avTools) , lNoBindist = False , lReleaseDay = Nothing , .. } - Right tver@GHCTargetVersion{ .. } -> do - lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget - fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions - pure $ Just $ ListResult - { lTool = GHC - , lVer = _tvVersion - , lCross = _tvTarget - , lTag = [] - , lInstalled = True - , lStray = True -- NOTE: cross currently cannot be installed via bindist - , lNoBindist = False - , lReleaseDay = Nothing - , .. - } Left e -> do logWarn $ "Could not parse version of stray directory" <> T.pack e @@ -309,15 +294,15 @@ listVersions lt' criteria hideOld showNightly days = do $ "Could not parse version of stray directory" <> T.pack e pure Nothing - currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult + currentGHCup :: Map.Map GHCTargetVersion VersionInfo -> Maybe ListResult currentGHCup av = - let currentVer = fromJust $ pvpToVersion ghcUpVer "" + let currentVer = mkTVer $ fromJust $ pvpToVersion ghcUpVer "" listVer = Map.lookup currentVer av latestVer = fst <$> headOf (getTagged Latest) av recommendedVer = fst <$> headOf (getTagged Latest) av isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer 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 , lCross = Nothing , lTool = GHCup @@ -346,18 +331,18 @@ listVersions lt' criteria hideOld showNightly days = do -> [Either FilePath Version] -> Maybe Version -> [Either FilePath Version] - -> (Version, VersionInfo) + -> (GHCTargetVersion, VersionInfo) -> 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 GHC -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v - let tver = mkTVer v - lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo' GHC tver + lSet <- fmap (== Just tver) $ ghcSet (_tvTarget tver) lInstalled <- ghcInstalled tver fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem v) hlsGHCVersions - pure ListResult { lVer = v, lCross = Nothing , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. } + hlsPowered <- fmap (elem tver) (fmap mkTVer <$> hlsGHCVersions) + pure ListResult { lVer = _tvVersion tver , lCross = _tvTarget tver , lTag = _viTags, lTool = t, lStray = False, lReleaseDay = _viReleaseDay, .. } Cabal -> do lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v let lSet = cSet == Just v diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index e68175f..e67e720 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -104,7 +104,7 @@ instance NFData Requirements -- | Description of all binary and source downloads. This is a tree -- of nested maps. type GHCupDownloads = Map Tool ToolVersionSpec -type ToolVersionSpec = Map Version VersionInfo +type ToolVersionSpec = Map GHCTargetVersion VersionInfo type ArchitectureSpec = Map Architecture PlatformSpec type PlatformSpec = Map Platform PlatformVersionSpec type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo @@ -593,7 +593,9 @@ data GHCTargetVersion = GHCTargetVersion { _tvTarget :: Maybe Text , _tvVersion :: Version } - deriving (Ord, Eq, Show) + deriving (Ord, Eq, Show, GHC.Generic) + +instance NFData GHCTargetVersion data GitBranch = GitBranch { ref :: String diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index b1c9a7e..40bbb10 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -95,13 +95,29 @@ instance FromJSON URI where Right x -> pure x 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 toJSON = toJSON . prettyV instance FromJSON Versioning where parseJSON = withText "Versioning" $ \t -> case versioning t of 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 toJSONKey = toJSONKeyText $ \x -> prettyV x diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 90db19a..475ea6f 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -62,7 +62,6 @@ import Control.Monad.Trans.Resource hiding ( throwM ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) ) import Data.Char ( isHexDigit ) -import Data.Bifunctor ( first ) import Data.ByteString ( ByteString ) import Data.Either import Data.Foldable @@ -774,13 +773,16 @@ getGHCForPVP' pvpIn ghcs' mt = do -- Just (PVP {_pComponents = 8 :| [8,4]}) getLatestToolFor :: MonadThrow m => Tool + -> Maybe Text -> PVP -> GHCupDownloads - -> m (Maybe (PVP, VersionInfo)) -getLatestToolFor tool pvpIn dls = do - let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls - let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls - pure . fmap (first fst) . headMay . filter (\((v, _), _) -> matchPVPrefix pvpIn v) $ ps + -> m (Maybe (PVP, VersionInfo, Maybe Text)) +getLatestToolFor tool target pvpIn dls = do + let ls :: [(GHCTargetVersion, VersionInfo)] + ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls + 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, -- picks the greatest version. getTagged :: Tag - -> Fold (Map.Map Version VersionInfo) (Version, VersionInfo) + -> Fold (Map.Map GHCTargetVersion VersionInfo) (GHCTargetVersion, VersionInfo) getTagged tag = to (Map.toDescList . Map.filter (\VersionInfo {..} -> tag `elem` _viTags)) % 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 mdv = Map.foldrWithKey (\k vi@VersionInfo{..} m -> 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) | 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 -getLatest :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) +getLatest :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo) 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 -getLatestNightly :: GHCupDownloads -> Tool -> Maybe (Version, VersionInfo) +getLatestNightly :: GHCupDownloads -> Tool -> Maybe (GHCTargetVersion, VersionInfo) 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 -- | Gets the latest GHC with a given base version. -getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (Version, VersionInfo) +getLatestBaseVersion :: GHCupDownloads -> PVP -> Maybe (GHCTargetVersion, VersionInfo) getLatestBaseVersion av pvpVer = headOf (ix GHC % getTagged (Base pvpVer)) av @@ -1101,9 +1103,9 @@ darwinNotarization _ _ = pure $ Right () 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 -getChangeLog dls tool (ToolVersion v') = +getChangeLog dls tool (ToolVersion (mkTVer -> v')) = preview (ix tool % ix v' % viChangeLog % _Just) dls getChangeLog dls tool (ToolTag tag) = preview (ix tool % pre (getTagged tag) % to snd % viChangeLog % _Just) dls @@ -1192,7 +1194,7 @@ rmBDir dir = withRunInIO (\run -> run $ $ rmPathForcibly dir) -getVersionInfo :: Version +getVersionInfo :: GHCTargetVersion -> Tool -> GHCupDownloads -> Maybe VersionInfo diff --git a/test/GHCup/ArbitraryTypes.hs b/test/GHCup/ArbitraryTypes.hs index 1cfe13b..54dedfd 100644 --- a/test/GHCup/ArbitraryTypes.hs +++ b/test/GHCup/ArbitraryTypes.hs @@ -183,6 +183,10 @@ instance Arbitrary GHCupInfo where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary GHCTargetVersion where + arbitrary = GHCTargetVersion Nothing <$> arbitrary + shrink = genericShrink + -- our maps are nested... the default size easily blows up most ppls ram