Improve generate subcommand
This commit is contained in:
parent
3ad280534b
commit
40bf6cd44b
GPG Key ID:
3786C5262ECB4A3F
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue