From 4c23f6a49ee5f33022c598b746c08878f4855822 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 8 Mar 2022 22:22:36 +0100 Subject: [PATCH] Generate tool tables for docs --- README.md | 2 +- ghcup-gen/Generate.hs | 84 +++++++++++++++++++++++++++++++++---------- ghcup-gen/Main.hs | 41 ++++++++++++--------- ghcup-gen/Validate.hs | 27 +++++++++----- 4 files changed, 111 insertions(+), 43 deletions(-) diff --git a/README.md b/README.md index 35e1a99..02c75a5 100644 --- a/README.md +++ b/README.md @@ -10,4 +10,4 @@ 6. run `cabal run ghcup-gen -- check -f ghcup-.yaml` 7. run `cabal run ghcup-gen -- check-tarballs -f ghcup-.yaml -u 'ghc-8\.10\.8'` 8. run `cabal run ghcup-gen -- generate-hls-ghcs -f ghcup-.yaml --format json -o hls-metadata-0.0.1.json` - +9. run `cabal run ghcup-gen -- generate-table -f ghcup-.yaml --stdout` and adjust [docs/install](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/docs/install.md) tables diff --git a/ghcup-gen/Generate.hs b/ghcup-gen/Generate.hs index 766bfef..60e88ef 100644 --- a/ghcup-gen/Generate.hs +++ b/ghcup-gen/Generate.hs @@ -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 $ "" + liftIO $ hPutStrLn handle $ "" + liftIO $ hPutStrLn handle $ "" + vers <- listVersions (Just tool) Nothing + forM_ (filter (\ListResult{..} -> not lStray) vers) $ \ListResult{..} -> do + liftIO $ hPutStrLn handle $ + "" + pure () + liftIO $ hPutStrLn handle $ "" + liftIO $ hPutStrLn handle $ "
" <> show tool <> " VersionTags
" + <> T.unpack (prettyVer lVer) + <> "" + <> intercalate ", " (filter (/= "") . fmap printTag $ sort lTag) + <> "
" + liftIO $ hPutStrLn handle $ "" + pure ExitSuccess + where + printTag Recommended = "recommended" + printTag Latest = "latest" + printTag Prerelease = "prerelease" + printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'') + printTag (UnknownTag t ) = t + printTag Old = "" diff --git a/ghcup-gen/Main.hs b/ghcup-gen/Main.hs index b826352..f739ff8 100644 --- a/ghcup-gen/Main.hs +++ b/ghcup-gen/Main.hs @@ -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 diff --git a/ghcup-gen/Validate.hs b/ghcup-gen/Validate.hs index 91bb612..2231597 100644 --- a/ghcup-gen/Validate.hs +++ b/ghcup-gen/Validate.hs @@ -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