Improve generate subcommand

This commit is contained in:
Julian Ospald 2022-03-08 14:59:14 +01:00
parent 3ad280534b
commit 40bf6cd44b
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
3 changed files with 55 additions and 23 deletions

View File

@ -9,55 +9,45 @@
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 qualified Data.Aeson.Encode.Pretty as Aeson
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.ByteString.Lazy as BSL
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 Format = FormatJSON
| FormatYAML
data GhcHlsVersions = GhcHlsVersions {
}
data Output
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
| StdOut
type HlsGhcVersions = Map Version (Map Architecture (Map Platform Version))
@ -74,8 +64,10 @@ generate :: ( MonadFail m
)
=> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> Format
-> Output
-> m ExitCode
generate dls _ = do
generate dls _ format output = do
let hlses = dls M.! HLS
r <- forM hlses $ \(_viArch -> archs) ->
forM archs $ \plats ->
@ -97,5 +89,10 @@ generate dls _ = do
<$> filter (match regex) files
pure ghcs
pure r
liftIO $ BS.putStr $ YAML.encodePretty YAML.defConfig r
let w = case format of
FormatYAML -> BSL.fromStrict $ YAML.encodePretty YAML.defConfig r
FormatJSON -> Aeson.encodePretty r
case output of
StdOut -> liftIO $ BSL.putStr w
FileOutput f -> liftIO $ BSL.writeFile f w
pure ExitSuccess

View File

@ -43,11 +43,45 @@ data Options = Options
{ optCommand :: Command
}
formatParser :: Parser Format
formatParser =
option
(eitherReader formatP)
(long "format" <> metavar "FORMAT" <> help
"Which format to use (JSON | YAML). Yaml is default."
<> value FormatJSON
)
where
formatP :: String -> Either String Format
formatP s' | t == T.pack "json" = Right FormatJSON
| t == T.pack "yaml" = Right FormatYAML
| t == T.pack "yml" = Right FormatYAML
| otherwise = Left ("Unknown format value: " <> s')
where t = T.toLower (T.pack s')
data Command = ValidateYAML ValidateYAMLOpts
| ValidateTarballs ValidateYAMLOpts TarballFilter
| GenerateHlsGhc ValidateYAMLOpts
| GenerateHlsGhc ValidateYAMLOpts Format Output
fileOutput :: Parser Output
fileOutput =
FileOutput
<$> strOption
(long "output-file" <> short 'o' <> metavar "FILENAME" <> help
"Output file to write to"
)
stdOutput :: Parser Output
stdOutput = flag'
StdOut
(short 'o' <> long "stdout" <> help "Output to stdout (default)")
outputP :: Parser Output
outputP = fileOutput <|> stdOutput
data Input
= FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
| StdInput
@ -113,7 +147,7 @@ com = subparser
<> command
"generate-hls-ghcs"
(info
((GenerateHlsGhc <$> validateYAMLOpts) <**> helper)
((GenerateHlsGhc <$> validateYAMLOpts <*> formatParser <*> outputP) <**> helper)
(progDesc "Generate a list of HLS-GHC support")
)
)
@ -145,7 +179,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)
GenerateHlsGhc vopts format output -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ generate dl m format output)
pure ()
where

View File

@ -45,6 +45,7 @@ executable ghcup-gen
-fwarn-incomplete-record-updates -threaded
build-depends:
, aeson-pretty ^>=0.8.9
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6