Generate tool tables for docs
This commit is contained in:
parent
3683db0155
commit
4c23f6a49e
GPG Key ID:
3786C5262ECB4A3F
@ -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
|
||||
|
||||
@ -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 = ""
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user