Create subcommand for generating HLS metadata

This commit is contained in:
Julian Ospald 2022-03-01 01:02:22 +01:00
parent 3c9c41f9a7
commit 2bedba1205
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
3 changed files with 112 additions and 0 deletions

101
ghcup-gen/Generate.hs Normal file
View File

@ -0,0 +1,101 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Generate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
import Codec.Archive
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.Trans.Resource ( runResourceT
, MonadUnliftIO
)
import Data.Containers.ListUtils ( nubOrd )
import Data.ByteString ( ByteString )
import Data.IORef
import Data.Either
import Data.Maybe
import Data.List
import Data.Map.Strict ( Map )
import Data.Versions
import Haskus.Utils.Variant.Excepts
import Optics
import System.FilePath
import System.Exit
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import GHCup.Utils.String.QQ
import qualified Data.ByteString as BS
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Version as V
import qualified Data.Yaml.Pretty as YAML
import qualified Text.Megaparsec as MP
data GhcHlsVersions = GhcHlsVersions {
}
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
-> m ExitCode
generate dls _ = do
let hlses = dls M.! HLS
r <- forM hlses $ \(_viArch -> archs) ->
forM archs $ \plats ->
forM plats $ \(head . M.toList -> (_, dli)) -> do
VRight r <- runResourceT . runE
@'[DigestError
, GPGError
, DownloadFailed
, UnknownArchive
, ArchiveResult
] $ do
fp <- liftE $ downloadCached dli Nothing
files <- liftE $ getArchiveFiles fp
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-([0-9]+\.)*([0-9]+)$|] :: ByteString)
let ghcs = rights $ MP.parse version' ""
. T.pack
. fromJust
. stripPrefix "haskell-language-server-"
<$> filter (match regex) files
pure ghcs
pure r
liftIO $ BS.putStr $ YAML.encodePretty YAML.defConfig r
pure ExitSuccess

View File

@ -29,6 +29,7 @@ import System.Environment
import System.Exit import System.Exit
import System.IO ( stderr ) import System.IO ( stderr )
import Text.Regex.Posix import Text.Regex.Posix
import Generate
import Validate import Validate
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
@ -44,6 +45,7 @@ data Options = Options
data Command = ValidateYAML ValidateYAMLOpts data Command = ValidateYAML ValidateYAMLOpts
| ValidateTarballs ValidateYAMLOpts TarballFilter | ValidateTarballs ValidateYAMLOpts TarballFilter
| GenerateHlsGhc ValidateYAMLOpts
data Input data Input
@ -108,6 +110,12 @@ com = subparser
((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper) ((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
(progDesc "Validate all tarballs (download and checksum)") (progDesc "Validate all tarballs (download and checksum)")
) )
<> command
"generate-hls-ghcs"
(info
((GenerateHlsGhc <$> validateYAMLOpts) <**> helper)
(progDesc "Generate a list of HLS-GHC support")
)
) )
@ -137,6 +145,7 @@ main = do
>>= \Options {..} -> case optCommand of >>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validate dl m) 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) ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validateTarballs tarballFilter dl m)
GenerateHlsGhc vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ generate dl m)
pure () pure ()
where where

View File

@ -23,6 +23,7 @@ source-repository head
executable ghcup-gen executable ghcup-gen
main-is: Main.hs main-is: Main.hs
other-modules: Validate other-modules: Validate
Generate
default-language: Haskell2010 default-language: Haskell2010
default-extensions: default-extensions:
DeriveGeneric DeriveGeneric
@ -51,6 +52,7 @@ executable ghcup-gen
, ghcup ^>=0.1.17.3 , ghcup ^>=0.1.17.3
, haskus-utils-variant ^>=3.2 , haskus-utils-variant ^>=3.2
, libarchive ^>=3.0.3.0 , libarchive ^>=3.0.3.0
, megaparsec ^>=9.0
, mtl ^>=2.2 , mtl ^>=2.2
, optics ^>=0.4 , optics ^>=0.4
, optparse-applicative >=0.15.1.0 && <0.17 , optparse-applicative >=0.15.1.0 && <0.17