ghcup-metadata/ghcup-gen/Generate.hs

161 lines
6.3 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Generate where
2022-03-08 21:22:36 +00:00
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
2022-03-08 13:59:14 +00:00
import Codec.Archive
2022-03-12 23:28:34 +00:00
import Control.DeepSeq
import Control.Exception ( evaluate )
2022-03-08 21:22:36 +00:00
import Control.Exception.Safe hiding ( handle )
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.Trans.Resource ( runResourceT
, MonadUnliftIO
)
2022-03-08 13:59:14 +00:00
import qualified Data.Aeson.Encode.Pretty as Aeson
import Data.ByteString ( ByteString )
import Data.Either
import Data.Maybe
import Data.List
import Data.Map.Strict ( Map )
import Data.Versions
import Haskus.Utils.Variant.Excepts
import System.Exit
2022-03-08 21:22:36 +00:00
import System.IO
import Text.Regex.Posix
import GHCup.Utils.String.QQ
2022-03-08 13:59:14 +00:00
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Yaml.Pretty as YAML
import qualified Text.Megaparsec as MP
2022-03-08 13:59:14 +00:00
data Format = FormatJSON
| FormatYAML
2022-03-08 13:59:14 +00:00
data Output
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
| StdOut
type HlsGhcVersions = Map Version (Map Architecture (Map Platform Version))
2022-03-08 21:22:36 +00:00
generateHLSGhc :: ( MonadFail m
, MonadMask m
, Monad m
, MonadReader env m
, HasSettings env
, HasDirs env
, HasLog env
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
, HasGHCupInfo env
)
=> Format
-> Output
-> m ExitCode
generateHLSGhc format output = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
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
2022-03-12 23:28:34 +00:00
filesL <- liftE $ getArchiveFiles fp
files <- liftIO $ evaluate $ force filesL
let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-([0-9]+\.)*([0-9]+)(\.exe)?$|] :: ByteString)
let ghcs = rights $ MP.parse version' ""
. T.pack
. fromJust
. stripPrefix "haskell-language-server-"
2022-03-12 23:28:34 +00:00
. stripExe
<$> filter (match regex) files
pure ghcs
pure r
2022-03-08 13:59:14 +00:00
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
2022-03-12 23:28:34 +00:00
where
stripExe :: String -> String
stripExe f = case reverse f of
('e':'x':'e':'.':r) -> reverse r
_ -> f
2022-03-08 21:22:36 +00:00
generateTable :: ( MonadFail m
, MonadMask m
, Monad m
, MonadReader env m
, HasSettings env
, HasDirs env
, HasLog env
, MonadThrow m
, MonadIO m
, HasPlatformReq env
, HasGHCupInfo env
, MonadUnliftIO m
)
=> Output
-> m ExitCode
generateTable output = do
handle <- case output of
StdOut -> pure stdout
FileOutput fp -> liftIO $ openFile fp WriteMode
forM_ [GHC,Cabal,HLS,Stack] $ \tool -> do
2022-03-18 17:51:55 +00:00
case tool of
GHC -> liftIO $ hPutStrLn handle $ "<details> <summary>Show all supported <a href='https://www.haskell.org/ghc/'>GHC</a> versions</summary>"
Cabal -> liftIO $ hPutStrLn handle $ "<details> <summary>Show all supported <a href='https://cabal.readthedocs.io/en/stable/'>cabal-install</a> versions</summary>"
HLS -> liftIO $ hPutStrLn handle $ "<details> <summary>Show all supported <a href='https://haskell-language-server.readthedocs.io/en/stable/'>HLS</a> versions</summary>"
Stack -> liftIO $ hPutStrLn handle $ "<details> <summary>Show all supported <a href='https://docs.haskellstack.org/en/stable/README/'>Stack</a> versions</summary>"
2022-03-08 21:22:36 +00:00
liftIO $ hPutStrLn handle $ "<table>"
liftIO $ hPutStrLn handle $ "<thead><tr><th>" <> show tool <> " Version</th><th>Tags</th></tr></thead>"
liftIO $ hPutStrLn handle $ "<tbody>"
2022-03-18 17:51:55 +00:00
vers <- reverse <$> listVersions (Just tool) Nothing
2022-03-08 21:22:36 +00:00
forM_ (filter (\ListResult{..} -> not lStray) vers) $ \ListResult{..} -> do
liftIO $ hPutStrLn handle $
"<tr><td>"
<> T.unpack (prettyVer lVer)
<> "</td><td>"
<> intercalate ", " (filter (/= "") . fmap printTag $ sort lTag)
<> "</td></tr>"
pure ()
liftIO $ hPutStrLn handle $ "</tbody>"
liftIO $ hPutStrLn handle $ "</table>"
2022-03-18 17:51:55 +00:00
liftIO $ hPutStrLn handle $ "</details>"
2022-03-08 21:22:36 +00:00
liftIO $ hPutStrLn handle $ ""
pure ExitSuccess
where
printTag Recommended = "<span style=\"color:green\">recommended</span>"
printTag Latest = "<span style=\"color:blue\">latest</span>"
printTag Prerelease = "<span style=\"color:red\">prerelease</span>"
printTag (Base pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
printTag (UnknownTag t ) = t
printTag Old = ""