Remove globalTools from metadata

This commit is contained in:
Julian Ospald 2023-11-13 15:37:36 +08:00
parent 0eba225723
commit d6601b0353
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
11 changed files with 21172 additions and 14730 deletions

View File

@ -683,7 +683,7 @@ settings' = unsafePerformIO $ do
newIORef $ AppState defaultSettings newIORef $ AppState defaultSettings
dirs dirs
defaultKeyBindings defaultKeyBindings
(GHCupInfo mempty mempty mempty) (GHCupInfo mempty mempty)
(PlatformRequest A_64 Darwin Nothing) (PlatformRequest A_64 Darwin Nothing)
loggerConfig loggerConfig

View File

@ -261,7 +261,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
Just _ -> pure () Just _ -> pure ()
-- TODO: always run for windows -- TODO: always run for windows
siletRunLogger (flip runReaderT s' $ runE ensureGlobalTools) >>= \case siletRunLogger (flip runReaderT s' $ runE ensureShimGen) >>= \case
VRight _ -> pure () VRight _ -> pure ()
VLeft e -> do VLeft e -> do
runLogger runLogger

View File

@ -170,7 +170,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
(ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <- (ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <-
M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions
let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo') let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo')
pure (GHCupInfo mempty ghcupDownloads' mempty) pure (GHCupInfo mempty ghcupDownloads')
where where
fromDownloadInfo :: DownloadInfo -> VersionInfo fromDownloadInfo :: DownloadInfo -> VersionInfo
fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli)) fromDownloadInfo dli = let aspec = M.singleton arch (M.singleton plat (M.singleton Nothing dli))
@ -189,9 +189,8 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo" mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
mergeGhcupInfo xs@(GHCupInfo{}: _) = mergeGhcupInfo xs@(GHCupInfo{}: _) =
let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs) let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs)
newGlobalTools = M.unionsWith (\_ a2 -> a2 ) (_globalTools <$> xs)
newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs) newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools in pure $ GHCupInfo newToolReqs newDownloads

View File

@ -209,7 +209,6 @@ instance HFErrorProject NoCompatiblePlatform where
-- | Unable to find a download for the requested version/distro. -- | Unable to find a download for the requested version/distro.
data NoDownload = NoDownload GHCTargetVersion Tool (Maybe PlatformRequest) data NoDownload = NoDownload GHCTargetVersion Tool (Maybe PlatformRequest)
| NoDownload' GlobalTool
deriving Show deriving Show
instance Pretty NoDownload where instance Pretty NoDownload where
@ -227,7 +226,6 @@ instance Pretty NoDownload where
<> T.unpack (prettyVer vv) <> T.unpack (prettyVer vv)
<> "'" <> "'"
| otherwise = text $ "Unable to find a download for " <> T.unpack (tVerToText tver) | otherwise = text $ "Unable to find a download for " <> T.unpack (tVerToText tver)
pPrint (NoDownload' globalTool) = text $ "Unable to find a download for " <> prettyShow globalTool
instance HFErrorProject NoDownload where instance HFErrorProject NoDownload where
eBase _ = 10 eBase _ = 10

View File

@ -387,7 +387,7 @@ rmLink fp
-- --
-- This overwrites previously existing files. -- This overwrites previously existing files.
-- --
-- On windows, this requires that 'ensureGlobalTools' was run beforehand. -- On windows, this requires that 'ensureShimGen' was run beforehand.
createLink :: ( MonadMask m createLink :: ( MonadMask m
, MonadThrow m , MonadThrow m
, HasLog env , HasLog env

View File

@ -74,7 +74,6 @@ data KeyCombination = KeyCombination { key :: Key, mods :: [Modifier] }
data GHCupInfo = GHCupInfo data GHCupInfo = GHCupInfo
{ _toolRequirements :: ToolRequirements { _toolRequirements :: ToolRequirements
, _ghcupDownloads :: GHCupDownloads , _ghcupDownloads :: GHCupDownloads
, _globalTools :: Map GlobalTool DownloadInfo
} }
deriving (Show, GHC.Generic, Eq) deriving (Show, GHC.Generic, Eq)
@ -136,14 +135,6 @@ instance Pretty Tool where
instance NFData Tool instance NFData Tool
data GlobalTool = ShimGen
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
instance NFData GlobalTool
instance Pretty GlobalTool where
pPrint ShimGen = text "shimgen"
-- | All necessary information of a tool version, including -- | All necessary information of a tool version, including
-- source download and per-architecture downloads. -- source download and per-architecture downloads.

View File

@ -59,7 +59,6 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Chunk
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Release deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Release
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GlobalTool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting
@ -158,12 +157,6 @@ instance ToJSONKey Tool where
instance FromJSONKey Tool where instance FromJSONKey Tool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSONKey GlobalTool where
toJSONKey = genericToJSONKey defaultJSONKeyOptions
instance FromJSONKey GlobalTool where
fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
instance ToJSON TarDir where instance ToJSON TarDir where
toJSON (RealDir p) = toJSON p toJSON (RealDir p) = toJSON p
toJSON (RegexDir r) = object ["RegexDir" .= r] toJSON (RegexDir r) = object ["RegexDir" .= r]
@ -288,9 +281,8 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Versio
instance FromJSON GHCupInfo where instance FromJSON GHCupInfo where
parseJSON = withObject "GHCupInfo" $ \o -> do parseJSON = withObject "GHCupInfo" $ \o -> do
toolRequirements' <- o .:? "toolRequirements" toolRequirements' <- o .:? "toolRequirements"
globalTools' <- o .:? "globalTools"
ghcupDownloads' <- o .: "ghcupDownloads" ghcupDownloads' <- o .: "ghcupDownloads"
pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads' (fromMaybe mempty globalTools')) pure (GHCupInfo (fromMaybe mempty toolRequirements') ghcupDownloads')
deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo deriveToJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo

View File

@ -1199,24 +1199,22 @@ getVersionInfo v' tool =
) )
ensureGlobalTools :: ( MonadMask m ensureShimGen :: ( MonadMask m
, MonadThrow m , MonadThrow m
, HasLog env , HasLog env
, MonadIO m , MonadIO m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, HasGHCupInfo env , HasGHCupInfo env
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
) )
=> Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m () => Excepts '[GPGError, DigestError, ContentLengthError, DownloadFailed, NoDownload] m ()
ensureGlobalTools ensureShimGen
| isWindows = do | isWindows = do
(GHCupInfo _ _ gTools) <- lift getGHCupInfo
dirs <- lift getDirs dirs <- lift getDirs
shimDownload <- liftE $ lE @_ @'[NoDownload] let shimDownload = DownloadInfo shimGenURL Nothing shimGenSHA Nothing Nothing
$ maybe (Left (NoDownload' ShimGen)) Right $ Map.lookup ShimGen gTools
let dl = downloadCached' shimDownload (Just "gs.exe") Nothing let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
void $ (\DigestError{} -> do void $ (\DigestError{} -> do
lift $ logWarn "Digest doesn't match, redownloading gs.exe..." lift $ logWarn "Digest doesn't match, redownloading gs.exe..."

View File

@ -39,6 +39,12 @@ ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/
stackSetupURL :: URI stackSetupURL :: URI
stackSetupURL = [uri|https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml|] stackSetupURL = [uri|https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/stack-setup-2.yaml|]
shimGenURL :: URI
shimGenURL = [uri|https://downloads.haskell.org/~ghcup/shimgen/shim-2.exe|]
shimGenSHA :: T.Text
shimGenSHA = T.pack "7c55e201f71860c5babea886007c8fa44b861abf50d1c07e5677eb0bda387a70"
-- | The current ghcup version. -- | The current ghcup version.
ghcUpVer :: V.PVP ghcUpVer :: V.PVP
ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version

View File

@ -175,10 +175,6 @@ instance Arbitrary Tool where
arbitrary = genericArbitrary arbitrary = genericArbitrary
shrink = genericShrink shrink = genericShrink
instance Arbitrary GlobalTool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GHCupInfo where instance Arbitrary GHCupInfo where
arbitrary = genericArbitrary arbitrary = genericArbitrary
shrink = genericShrink shrink = genericShrink

File diff suppressed because it is too large Load Diff