ghcup-metadata/ghcup-gen/Main.hs

233 lines
8.1 KiB
Haskell
Raw Normal View History

2021-10-27 13:04:49 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import GHCup.Types
import GHCup.Errors
import GHCup.Platform
import GHCup.Utils.Dirs
2023-01-13 04:38:23 +00:00
import GHCup.Prelude.Logger
2021-10-27 13:04:49 +00:00
import GHCup.Types.JSON ( )
import Control.Exception ( displayException )
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.IO.Class
import Data.Char ( toLower )
import Data.Maybe
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) )
#endif
import Options.Applicative hiding ( style )
import Haskus.Utils.Variant.Excepts
import System.Console.Pretty
import System.Environment
import System.Exit
import System.IO ( stderr )
import Text.Regex.Posix
import Generate
2021-10-27 13:04:49 +00:00
import Validate
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text.IO as T
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.Yaml.Aeson as Y
data Options = Options
{ optCommand :: Command
}
2022-03-08 13:59:14 +00:00
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')
2021-10-27 13:04:49 +00:00
data Command = ValidateYAML ValidateYAMLOpts
| ValidateTarballs ValidateYAMLOpts TarballFilter
2022-03-08 13:59:14 +00:00
| GenerateHlsGhc ValidateYAMLOpts Format Output
2022-03-08 21:22:36 +00:00
| GenerateToolTable ValidateYAMLOpts Output
| GenerateSystemDepsInfo ValidateYAMLOpts Output
2022-03-08 13:59:14 +00:00
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)")
2021-10-27 13:04:49 +00:00
2022-03-08 13:59:14 +00:00
outputP :: Parser Output
outputP = fileOutput <|> stdOutput
2021-10-27 13:04:49 +00:00
data Input
= FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
| StdInput
fileInput :: Parser Input
fileInput =
FileInput
<$> strOption
(long "file" <> short 'f' <> metavar "FILENAME" <> help
"Input file to validate"
)
stdInput :: Parser Input
stdInput = flag'
StdInput
(short 'i' <> long "stdin" <> help "Validate from stdin (default)")
inputP :: Parser Input
inputP = fileInput <|> stdInput
data ValidateYAMLOpts = ValidateYAMLOpts
2023-10-01 07:39:32 +00:00
{ vChannel :: DistributionChannel
, vInput :: Maybe Input
2021-10-27 13:04:49 +00:00
}
validateYAMLOpts :: Parser ValidateYAMLOpts
2023-10-01 07:39:32 +00:00
validateYAMLOpts = ValidateYAMLOpts <$> channelParser <*> optional inputP
channelParser :: Parser DistributionChannel
channelParser =
option
(eitherReader chanP)
(long "channel" <> metavar "CHANNEL" <> help
"Signal which distribution channel the YAML denotes: (main | prerelease | nightly). Main is defaul."
<> value MainChan
)
where
chanP :: String -> Either String DistributionChannel
chanP s' | t == T.pack "main" = Right MainChan
| t == T.pack "prerelease" = Right PrereleaseChan
| t == T.pack "prereleases" = Right PrereleaseChan
| t == T.pack "nightly" = Right NightlyChan
| t == T.pack "nightlies" = Right NightlyChan
| otherwise = Left ("Unknown channel value: " <> s')
where t = T.toLower (T.pack s')
2021-10-27 13:04:49 +00:00
tarballFilterP :: Parser TarballFilter
tarballFilterP = option readm $
long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
<> help "Only check certain tarballs (format: <tool>-<version>)"
where
2023-11-17 14:24:19 +00:00
def = TarballFilter Nothing (makeRegex ("" :: String))
2021-10-27 13:04:49 +00:00
readm = do
s <- str
case span (/= '-') s of
(_, []) -> fail "invalid format, missing '-' after the tool name"
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
2023-11-17 14:24:19 +00:00
pure (TarballFilter $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
2021-10-27 13:04:49 +00:00
_ -> fail "invalid tool"
low = fmap toLower
opts :: Parser Options
opts = Options <$> com
com :: Parser Command
com = subparser
( command
"check"
( ValidateYAML
<$> info (validateYAMLOpts <**> helper)
(progDesc "Validate the YAML")
)
<> command
"check-tarballs"
(info
((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
)
<> command
"generate-hls-ghcs"
(info
2022-03-08 13:59:14 +00:00
((GenerateHlsGhc <$> validateYAMLOpts <*> formatParser <*> outputP) <**> helper)
(progDesc "Generate a list of HLS-GHC support")
)
2022-03-08 21:22:36 +00:00
<> command
"generate-tool-table"
2022-03-08 21:22:36 +00:00
(info
((GenerateToolTable <$> validateYAMLOpts <*> outputP) <**> helper)
(progDesc "Generate a markdown table of available tool versions")
)
<> command
"generate-system-deps-info"
(info
((GenerateSystemDepsInfo <$> validateYAMLOpts <*> outputP) <**> helper)
(progDesc "Generate a markdown info for system dependencies")
)
2021-10-27 13:04:49 +00:00
)
main :: IO ()
main = do
no_color <- isJust <$> lookupEnv "NO_COLOR"
let loggerConfig = LoggerConfig { lcPrintDebug = True
, consoleOutter = T.hPutStr stderr
, fileOutter = \_ -> pure ()
, fancyColors = not no_color
}
dirs <- liftIO getAllDirs
2023-01-13 04:38:23 +00:00
let leanAppstate = LeanAppState (Settings True 0 Lax False Never Curl True GHCupURL False GPGNone True Nothing (DM mempty)) dirs defaultKeyBindings loggerConfig
2021-10-27 13:04:49 +00:00
pfreq <- (
flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
liftIO $ exitWith (ExitFailure 2)
2023-11-17 14:24:19 +00:00
let appstate = AppState (Settings True 0 Lax False Never Curl True GHCupURL False GPGNone True Nothing (DM mempty)) dirs defaultKeyBindings (GHCupInfo mempty mempty Nothing) pfreq loggerConfig
2021-10-27 13:04:49 +00:00
2022-03-08 21:22:36 +00:00
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
2021-10-27 13:04:49 +00:00
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
2023-10-01 07:39:32 +00:00
ValidateYAML vopts@ValidateYAMLOpts{ .. } -> withValidateYamlOpts vopts (validate vChannel)
2022-03-08 21:22:36 +00:00
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter)
GenerateHlsGhc vopts format output -> withValidateYamlOpts vopts (generateHLSGhc format output)
GenerateToolTable vopts output -> withValidateYamlOpts vopts (generateTable output)
GenerateSystemDepsInfo vopts output -> withValidateYamlOpts vopts (generateSystemInfoWithDistroVersion output)
2021-10-27 13:04:49 +00:00
pure ()
where