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

Merge branch 'monday-improvements'

Browse Source
This commit is contained in:
Julian Ospald 2023-11-14 23:16:42 +08:00
commit b1106985ec
No known key found for this signature in database
GPG Key ID: 4275CDA6A29BED43
16 changed files with 15246 additions and 14299 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.github/workflows/release.yaml vendored
View File

@ -322,7 +322,7 @@ jobs:
with:
name: testfiles
path: |
./test/golden/unix/GHCupInfo*json
./test/ghcup-test/golden/unix/GHCupInfo*json
test-arm:
name: Test ARM
@ -389,7 +389,7 @@ jobs:
with:
name: testfiles
path: |
./test/golden/unix/GHCupInfo*json
./test/ghcup-test/golden/unix/GHCupInfo*json
test-macwin:
name: Test Mac/Win
@ -458,7 +458,7 @@ jobs:
with:
name: testfiles
path: |
./test/golden/windows/GHCupInfo*json
./test/ghcup-test/golden/windows/GHCupInfo*json
- if: failure() && runner.os != 'Windows'
name: Upload artifact
@ -466,7 +466,7 @@ jobs:
with:
name: testfiles
path: |
./test/golden/unix/GHCupInfo*json
./test/ghcup-test/golden/unix/GHCupInfo*json
hls:
name: hls
needs: build-linux

2
app/ghcup/BrickMain.hs
View File

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

2
app/ghcup/Main.hs
View File

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

37
lib/GHCup/Download.hs
View File

@ -158,7 +158,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
catchE @JSONError (\(JSONDecodeError _) -> do
logDebug $ "Couldn't decode " <> T.pack base <> " as GHCupInfo, trying as SetupInfo: "
Right <$> decodeMetadata @Stack.SetupInfo base)
$ fmap Left $ decodeMetadata @GHCupInfo base
$ fmap Left (decodeMetadata @GHCupInfo base >>= \gI -> warnOnMetadataUpdate uri gI >> pure gI)
fromStackSetupInfo :: MonadThrow m
=> Stack.SetupInfo
@ -170,7 +170,7 @@ getDownloadsF pfreq@(PlatformRequest arch plat _) = do
(ghcupInfo' :: M.Map GHCTargetVersion DownloadInfo) <-
M.mapKeys mkTVer <$> M.traverseMaybeWithKey (\_ a -> pure $ fromStackDownloadInfo a) ghcVersions
let ghcupDownloads' = M.singleton GHC (M.map fromDownloadInfo ghcupInfo')
pure (GHCupInfo mempty ghcupDownloads' mempty)
pure (GHCupInfo mempty ghcupDownloads' Nothing)
where
fromDownloadInfo :: DownloadInfo -> VersionInfo
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 xs@(GHCupInfo{}: _) =
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)
in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
in pure $ GHCupInfo newToolReqs newDownloads Nothing
@ -308,6 +307,36 @@ getBase uri = do
pure f
warnOnMetadataUpdate ::
( MonadReader env m
, MonadIO m
, HasLog env
, HasDirs env
)
=> URI
-> GHCupInfo
-> m ()
warnOnMetadataUpdate uri (GHCupInfo { _metadataUpdate = Just newUri })
| scheme' uri == "file"
, urlBase' uri /= urlBase' newUri = do
confFile <- getConfigFilePath'
logWarn $ "New metadata version detected"
<> "\n old URI: " <> (decUTF8Safe . serializeURIRef') uri
<> "\n new URI: " <> (decUTF8Safe . serializeURIRef') newUri
<> "\nYou might need to update your " <> T.pack confFile
| scheme' uri /= "file"
, uri /= newUri = do
confFile <- getConfigFilePath'
logWarn $ "New metadata version detected"
<> "\n old URI: " <> (decUTF8Safe . serializeURIRef') uri
<> "\n new URI: " <> (decUTF8Safe . serializeURIRef') newUri
<> "\nYou might need to update your " <> T.pack confFile
where
scheme' = view (uriSchemeL' % schemeBSL')
urlBase' = T.unpack . decUTF8Safe . urlBaseName . view pathL'
warnOnMetadataUpdate _ _ = pure ()
decodeMetadata :: forall j m env .
( MonadReader env m
, HasDirs env

2
lib/GHCup/Errors.hs
View File

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

3
lib/GHCup/GHC.hs
View File

@ -763,7 +763,8 @@ rmGHCVer ver = do
Dirs {..} <- lift getDirs
lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir </> "share")
when isSetGHC $ do
lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir </> "share")

2
lib/GHCup/Prelude/File.hs
View File

@ -387,7 +387,7 @@ rmLink fp
--
-- 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
, MonadThrow m
, HasLog env

10
lib/GHCup/Types.hs
View File

@ -74,7 +74,7 @@ data KeyCombination = KeyCombination { key :: Key, mods :: [Modifier] }
data GHCupInfo = GHCupInfo
{ _toolRequirements :: ToolRequirements
, _ghcupDownloads :: GHCupDownloads
, _globalTools :: Map GlobalTool DownloadInfo
, _metadataUpdate :: Maybe URI
}
deriving (Show, GHC.Generic, Eq)
@ -136,14 +136,6 @@ instance Pretty Tool where
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
-- source download and per-architecture downloads.

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

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

30
lib/GHCup/Utils.hs
View File

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

7
lib/GHCup/Utils/Dirs.hs
View File

@ -29,6 +29,7 @@ module GHCup.Utils.Dirs
, relativeSymlink
, withGHCupTmpDir
, getConfigFilePath
, getConfigFilePath'
, useXDG
, cleanupTrash
@ -360,6 +361,12 @@ getConfigFilePath = do
confDir <- liftIO ghcupConfigDir
pure $ fromGHCupPath confDir </> "config.yaml"
getConfigFilePath' :: (MonadReader env m, HasDirs env) => m FilePath
getConfigFilePath' = do
Dirs {..} <- getDirs
pure $ fromGHCupPath confDir </> "config.yaml"
ghcupConfigFile :: (MonadIO m)
=> Excepts '[JSONError] m UserSettings
ghcupConfigFile = do

6
lib/GHCup/Version.hs
View File

@ -39,6 +39,12 @@ ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/
stackSetupURL :: URI
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.
ghcUpVer :: V.PVP
ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version

8
scripts/dev/update-shell-completions.sh Executable file
View File

@ -0,0 +1,8 @@
#!/bin/sh
set -xue
cabal --verbose=0 run ghcup:exe:ghcup -- --bash-completion-script ghcup > scripts/shell-completions/bash
cabal --verbose=0 run ghcup:exe:ghcup -- --zsh-completion-script ghcup > scripts/shell-completions/zsh
cabal --verbose=0 run ghcup:exe:ghcup -- --fish-completion-script ghcup > scripts/shell-completions/fish

4
test/ghcup-test/GHCup/ArbitraryTypes.hs
View File

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

29355
test/ghcup-test/golden/unix/GHCupInfo.json
View File

File diff suppressed because it is too large Load Diff

58
test/ghcup-test/golden/windows/GHCupInfo.json
View File

@ -4116,17 +4116,7 @@
}
}
},
"globalTools": {
"ShimGen": {
"dlCSize": -1,
"dlHash": "xrocmtsmjzgmemxrenf",
"dlOutput": null,
"dlSubdir": {
"RegexDir": "\u0013tt\u0013m-"
},
"dlUri": "https:wjmqkzflmlzetqdcxed"
}
},
"metadataUpdate": "https:ixnnceymgu",
"toolRequirements": {
"GHCup": {
"3.8.8": {
@ -9309,17 +9299,7 @@
}
}
},
"globalTools": {
"ShimGen": {
"dlCSize": -18,
"dlHash": "wbpx",
"dlOutput": null,
"dlSubdir": {
"RegexDir": "[u3"
},
"dlUri": "https:"
}
},
"metadataUpdate": "https:cxnnfovqllcccybmllaikuvluhp",
"toolRequirements": {
"HLS": {
"2.6.9": {
@ -11308,15 +11288,7 @@
}
}
},
"globalTools": {
"ShimGen": {
"dlCSize": null,
"dlHash": "yfwka",
"dlOutput": "c5q",
"dlSubdir": "􊆁M󿅃/|",
"dlUri": "https:yolsdtmmo"
}
},
"metadataUpdate": "http:fbptvnonarkxeszcsn",
"toolRequirements": {
"Cabal": {
"7.7.4": {
@ -13648,15 +13620,7 @@
"GHCup": {},
"Stack": {}
},
"globalTools": {
"ShimGen": {
"dlCSize": null,
"dlHash": "hoegok",
"dlOutput": null,
"dlSubdir": "􁃽\u0005]?9\u0001Q:𭲎8ᙣ𑐛'oD\u001a󱧼(𛆎􃥧\u0004\\𢨓[\u001e",
"dlUri": "https:nimu"
}
},
"metadataUpdate": null,
"toolRequirements": {
"Cabal": {
"3.5.4": {
@ -18153,17 +18117,7 @@
}
}
},
"globalTools": {
"ShimGen": {
"dlCSize": null,
"dlHash": "mpljxguikoebuynzv",
"dlOutput": "Q􆹿@i\"%\u0014gb0/PPYE\u001f\u0014KC`-wL",
"dlSubdir": {
"RegexDir": ".`_\u0005󹦸&󲥠\u0014^1Fml\u001e􄋔>o􅟘G"
},
"dlUri": "http:tmcnu"
}
},
"metadataUpdate": "http:ntkddscbgdrjmwymnvpqpmgr",
"toolRequirements": {
"GHC": {
"6.3.1": {
@ -19958,4 +19912,4 @@
}
],
"seed": 89490121
}
}