Create subcommand for generating HLS metadata

ghcup-gen/Generate.hs

@@ -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

ghcup-gen/Main.hs

@@ -29,6 +29,7 @@ import           System.Environment
 import           System.Exit
 import           System.IO                      ( stderr )
 import           Text.Regex.Posix
+import           Generate
 import           Validate
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
@@ -44,6 +45,7 @@ data Options = Options
 
 data Command = ValidateYAML ValidateYAMLOpts
              | ValidateTarballs ValidateYAMLOpts TarballFilter
+             | GenerateHlsGhc ValidateYAMLOpts
 
 
 data Input
@@ -108,6 +110,12 @@ com = subparser
          ((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
          (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
           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 -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ generate dl m)
   pure ()
 
  where

ghcup-gen/ghcup-gen.cabal

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