ghcup-hs/app/ghcup/GHCup/OptParse/Test.hs

189 lines
4.9 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.OptParse.Test where
import GHCup.OptParse.Common
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Dirs
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
import Codec.Archive
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import URI.ByteString hiding ( uriParser )
import qualified Data.Text as T
----------------
--[ Commands ]--
----------------
data TestCommand = TestGHC TestOptions
---------------
--[ Options ]--
---------------
data TestOptions = TestOptions
{ testVer :: Maybe ToolVersion
, testBindist :: Maybe URI
, addMakeArgs :: [T.Text]
}
---------------
--[ Footers ]--
---------------
testFooter :: String
testFooter = [s|Discussion:
Runs test suites from the test bindist.|]
---------------
--[ Parsers ]--
---------------
testParser :: Parser TestCommand
testParser =
subparser
( command
"ghc"
( TestGHC
<$> info
(testOpts (Just GHC) <**> helper)
( progDesc "Test GHC"
<> footerDoc (Just $ text testGHCFooter)
)
)
)
where
testGHCFooter :: String
testGHCFooter = [s|Discussion:
Runs the GHC test suite from the test bindist.|]
testOpts :: Maybe Tool -> Parser TestOptions
testOpts tool =
(\(u, v) args -> TestOptions v u args)
<$> ( ( (,)
<$> optional
(option
(eitherReader uriParser)
(short 'u' <> long "url" <> metavar "BINDIST_URL" <> help
"Install the specified version from this bindist"
<> completer (toolDlCompleter (fromMaybe GHC tool))
)
)
<*> (Just <$> toolVersionTagArgument Nothing tool)
)
<|> pure (Nothing, Nothing)
)
<*> many (argument str (metavar "MAKE_ARGS" <> help "Additional arguments to 'make', prefix with '-- ' (longopts)"))
---------------------------
--[ Effect interpreters ]--
---------------------------
type TestGHCEffects = [ DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, NoDownload
, ArchiveResult
, TarDirDoesNotExist
, UnknownArchive
, TestFailed
, NextVerNotFound
, TagNotFound
, NoToolVersionSet
]
runTestGHC :: AppState
-> Excepts TestGHCEffects (ResourceT (ReaderT AppState IO)) a
-> IO (VEither TestGHCEffects a)
runTestGHC appstate' =
flip runReaderT appstate'
. runResourceT
. runE
@TestGHCEffects
-------------------
--[ Entrypoints ]--
-------------------
test :: TestCommand -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
test testCommand settings getAppState' runLogger = case testCommand of
(TestGHC iopts) -> go iopts
where
go :: TestOptions -> IO ExitCode
go TestOptions{..} = do
s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState'
(case testBindist of
Nothing -> runTestGHC s' $ do
(v, vi) <- liftE $ fromVersion testVer GHC
liftE $ testGHCVer (_tvVersion v) addMakeArgs
pure vi
Just uri -> do
runTestGHC s'{ settings = settings {noVerify = True}} $ do
(v, vi) <- liftE $ fromVersion testVer GHC
liftE $ testGHCBindist (DownloadInfo uri (Just $ RegexDir ".*/.*") "" Nothing) (_tvVersion v) addMakeArgs
pure vi
)
>>= \case
VRight _ -> do
runLogger $ logInfo "GHC test successful"
pure ExitSuccess
VLeft e -> do
runLogger $ do
logError $ T.pack $ prettyHFError e
logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir)
pure $ ExitFailure 3