hasufell
/
ghcup-metadata
1
1
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Generate tool tables for docs

This commit is contained in:
Julian Ospald 2022-03-08 22:22:36 +01:00
parent 3683db0155
commit 4c23f6a49e
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
4 changed files with 111 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
README.md
View File

@ -10,4 +10,4 @@
6. run `cabal run ghcup-gen -- check -f ghcup-<yaml-ver>.yaml`
7. run `cabal run ghcup-gen -- check-tarballs -f ghcup-<yaml-ver>.yaml -u 'ghc-8\.10\.8'`
8. run `cabal run ghcup-gen -- generate-hls-ghcs -f ghcup-<yaml-ver>.yaml --format json -o hls-metadata-0.0.1.json`
9. run `cabal run ghcup-gen -- generate-table -f ghcup-<yaml-ver>.yaml --stdout` and adjust [docs/install](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/docs/install.md) tables

84
ghcup-gen/Generate.hs
View File

@ -9,6 +9,7 @@
module Generate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
@ -17,7 +18,7 @@ import GHCup.Utils
import Codec.Archive
import Control.Exception.Safe
import Control.Exception.Safe hiding ( handle )
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
@ -33,6 +34,7 @@ import Data.Map.Strict ( Map )
import Data.Versions
import Haskus.Utils.Variant.Excepts
import System.Exit
import System.IO
import Text.Regex.Posix
import GHCup.Utils.String.QQ
@ -51,23 +53,23 @@ data Output
type HlsGhcVersions = Map Version (Map Architecture (Map Platform Version))
generate :: ( MonadFail m
, MonadMask m
, Monad m
, MonadReader env m
, HasSettings env
, HasDirs env
, HasLog env
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
)
=> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> Format
-> Output
-> m ExitCode
generate dls _ format output = do
generateHLSGhc :: ( MonadFail m
, MonadMask m
, Monad m
, MonadReader env m
, HasSettings env
, HasDirs env
, HasLog env
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
, HasGHCupInfo env
)
=> Format
-> Output
-> m ExitCode
generateHLSGhc format output = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
let hlses = dls M.! HLS
r <- forM hlses $ \(_viArch -> archs) ->
forM archs $ \plats ->
@ -96,3 +98,49 @@ generate dls _ format output = do
StdOut -> liftIO $ BSL.putStr w
FileOutput f -> liftIO $ BSL.writeFile f w
pure ExitSuccess
generateTable :: ( MonadFail m
, MonadMask m
, Monad m
, MonadReader env m
, HasSettings env
, HasDirs env
, HasLog env
, MonadThrow m
, MonadIO m
, HasPlatformReq env
, HasGHCupInfo env
, MonadUnliftIO m
)
=> Output
-> m ExitCode
generateTable output = do
handle <- case output of
StdOut -> pure stdout
FileOutput fp -> liftIO $ openFile fp WriteMode
forM_ [GHC,Cabal,HLS,Stack] $ \tool -> do
liftIO $ hPutStrLn handle $ "<table>"
liftIO $ hPutStrLn handle $ "<thead><tr><th>" <> show tool <> " Version</th><th>Tags</th></tr></thead>"
liftIO $ hPutStrLn handle $ "<tbody>"
vers <- listVersions (Just tool) Nothing
forM_ (filter (\ListResult{..} -> not lStray) vers) $ \ListResult{..} -> do
liftIO $ hPutStrLn handle $
"<tr><td>"
<> T.unpack (prettyVer lVer)
<> "</td><td>"
<> intercalate ", " (filter (/= "") . fmap printTag $ sort lTag)
<> "</td></tr>"
pure ()
liftIO $ hPutStrLn handle $ "</tbody>"
liftIO $ hPutStrLn handle $ "</table>"
liftIO $ hPutStrLn handle $ ""
pure ExitSuccess
where
printTag Recommended = "<span style=\"color:green\">recommended</span>"
printTag Latest = "<span style=\"color:blue\">latest</span>"
printTag Prerelease = "<span style=\"color:red\">prerelease</span>"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t
printTag Old = ""

41
ghcup-gen/Main.hs
View File

@ -64,6 +64,7 @@ formatParser =
data Command = ValidateYAML ValidateYAMLOpts
| ValidateTarballs ValidateYAMLOpts TarballFilter
| GenerateHlsGhc ValidateYAMLOpts Format Output
| GenerateToolTable ValidateYAMLOpts Output
fileOutput :: Parser Output
@ -150,6 +151,12 @@ com = subparser
((GenerateHlsGhc <$> validateYAMLOpts <*> formatParser <*> outputP) <**> helper)
(progDesc "Generate a list of HLS-GHC support")
)
<> command
"generate-table"
(info
((GenerateToolTable <$> validateYAMLOpts <*> outputP) <**> helper)
(progDesc "Generate a markdown table of available tool versions")
)
)
@ -175,24 +182,26 @@ main = do
let appstate = AppState (Settings True 0 False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
let withValidateYamlOpts vopts f = case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit f
valAndExit f contents = do
ginfo <- case Y.decodeEither' contents of
Right r -> pure r
Left e -> die (color Red $ displayException e)
r <- flip runReaderT appstate { ghcupInfo = ginfo } f
exitWith r
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validate dl m)
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validateTarballs tarballFilter dl m)
GenerateHlsGhc vopts format output -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ generate dl m format output)
ValidateYAML vopts -> withValidateYamlOpts vopts validate
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter)
GenerateHlsGhc vopts format output -> withValidateYamlOpts vopts (generateHLSGhc format output)
GenerateToolTable vopts output -> withValidateYamlOpts vopts (generateTable output)
pure ()
where
withValidateYamlOpts vopts f = case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit f
valAndExit f contents = do
(GHCupInfo _ av gt) <- case Y.decodeEither' contents of
Right r -> pure r
Left e -> die (color Red $ displayException e)
f av gt
>>= exitWith

27
ghcup-gen/Validate.hs
View File

@ -58,11 +58,18 @@ addError = do
liftIO $ modifyIORef ref (+ 1)
validate :: (Monad m, MonadReader env m, HasLog env, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
validate dls _ = do
validate :: ( Monad m
, MonadReader env m
, HasLog env
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
, HasGHCupInfo env
)
=> m ExitCode
validate = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
ref <- liftIO $ newIORef 0
-- verify binary downloads --
@ -117,6 +124,7 @@ validate dls _ = do
_ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
checkUniqueTags tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
let nonUnique =
fmap fst
@ -145,6 +153,7 @@ validate dls _ = do
isUniqueTag (UnknownTag _) = False
checkGHCVerIsValid = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
forM_ ghcVers $ \v ->
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
@ -155,6 +164,7 @@ validate dls _ = do
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of
False -> do
@ -164,6 +174,7 @@ validate dls _ = do
-- all GHC versions must have a base tag
checkGHCHasBaseVersion = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
False -> do
@ -190,12 +201,12 @@ validateTarballs :: ( Monad m
, MonadMask m
, Alternative m
, MonadFail m
, HasGHCupInfo env
)
=> TarballFilter
-> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
validateTarballs (TarballFilter etool versionRegex) dls gt = do
validateTarballs (TarballFilter etool versionRegex) = do
GHCupInfo { _ghcupDownloads = dls, _globalTools = gt } <- getGHCupInfo
ref <- liftIO $ newIORef 0
-- download/verify all tarballs