CLI.hs

module Tricorder.CLI
    ( showLog
    , showSource
    , showStatus
    , showTests
    ) where

import Atelier.Effects.Clock (Clock, currentTimeZone)
import Atelier.Effects.Console (Console)
import Atelier.Effects.Delay (Delay)
import Atelier.Effects.Exit (Exit, exitFailure)
import Atelier.Effects.File (File)
import Atelier.Effects.FileSystem (FileSystem, doesFileExist, followFile, readFileLbs)
import Data.Aeson (encode)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.LocalTime (utcToLocalTime)
import Effectful.Reader.Static (Reader, ask)

import Atelier.Effects.Console qualified as Console
import Data.ByteString.Lazy qualified as BSL
import Data.Text qualified as T

import Tricorder.Arguments
    ( FollowMode (..)
    , OutputFormat (..)
    , StatusOptions (..)
    , TestOptions (..)
    , Verbosity (..)
    , WaitMode (..)
    )
import Tricorder.BuildState
    ( BuildPhase (..)
    , BuildProgress (..)
    , BuildResult (..)
    , BuildState (..)
    , Diagnostic (..)
    , Severity (..)
    , TestCase (..)
    , TestCaseOutcome (..)
    , TestRun (..)
    , TestRunCompletion (..)
    , TestRunError (..)
    )
import Tricorder.CLI.Render
    ( diagnosticLineIndexed
    , formatDuration
    , renderSourceResults
    )
import Tricorder.Effects.UnixSocket (UnixSocket)
import Tricorder.GhcPkg.Types (SourceQuery)
import Tricorder.Runtime (SocketPath (..))
import Tricorder.Socket.Client
    ( querySource
    , queryStatus
    , queryStatusWait
    )
import Tricorder.TestOutput (stripGhciNoise)


-- | Print a build-command failure message and exit non-zero.
reportBuildFailed :: (Console :> es, Exit :> es) => Text -> Eff es a
reportBuildFailed msg = do
    Console.putTextLn "Build command failed:"
    Console.putTextLn msg
    exitFailure


showStatus
    :: ( Clock :> es
       , Console :> es
       , Exit :> es
       , File :> es
       , Reader SocketPath :> es
       , UnixSocket :> es
       )
    => StatusOptions -> Eff es ()
showStatus opts = do
    SocketPath sockPath <- ask
    when (opts.wait == WaitForBuild && opts.format == TextOutput) $ do
        current <- queryStatus sockPath
        case current of
            Right BuildState {phase = Building _} -> Console.putStrLn "Building..."
            Right BuildState {phase = Restarting} -> Console.putStrLn "Restarting..."
            Right BuildState {phase = Testing _} -> Console.putStrLn "Testing..."
            _ -> pure ()
    result <-
        case opts.wait of
            WaitForBuild -> queryStatusWait sockPath
            ShowCurrent -> queryStatus sockPath
    case result of
        Left err -> Console.putTextLn $ "Error: " <> err
        Right state ->
            case opts.format of
                JsonOutput -> do
                    Console.putStr $ BSL.toStrict $ encode state
                    Console.putStrLn ""
                TextOutput ->
                    renderText opts.verbosity opts.expand state
  where
    renderText verbosity expand state = case state.phase of
        Building _ -> Console.putStrLn "Building..."
        Restarting -> Console.putStrLn "Restarting..."
        Testing _ -> Console.putStrLn "Testing..."
        BuildFailed msg -> reportBuildFailed msg
        Done r -> do
            tz <- currentTimeZone
            case expand of
                Just n ->
                    case r.diagnostics !!? (n - 1) of
                        Nothing ->
                            Console.putTextLn
                                $ "No diagnostic #"
                                    <> show n
                                    <> " (current build has "
                                    <> show (length r.diagnostics)
                                    <> ")"
                        Just d -> do
                            Console.putTextLn $ diagnosticLineIndexed n d
                            Console.putText d.text
                Nothing -> do
                    let printDiag (i, d) = case verbosity of
                            Verbose -> do
                                Console.putTextLn $ diagnosticLineIndexed i d
                                Console.putText d.text
                            Concise ->
                                Console.putTextLn $ diagnosticLineIndexed i d
                    mapM_ printDiag (zip [1 ..] r.diagnostics)
                    Console.putTextLn $ buildSummary tz r
                    mapM_ (printTestRun verbosity) r.testRuns
                    when (buildHasErrors r || testsFailed r) exitFailure

    printTestRun verbosity tr = do
        Console.putTextLn $ case tr of
            TestRunning t Nothing -> t <> "  running..."
            TestRunning t (Just p) -> t <> "  running... (" <> show p.compiled <> "/" <> show p.total <> ")"
            TestRunErrored e -> e.target <> "  error: " <> e.message
            TestRunCompleted c -> c.target <> "  " <> completionSummary c
        when (verbosity == Verbose) $ case tr of
            TestRunCompleted c ->
                mapM_ (Console.putTextLn . ("  " <>)) (stripGhciNoise (T.lines c.output))
            _ -> pure ()

    buildHasErrors r = any ((== SError) . (.severity)) r.diagnostics
    testsFailed r = any isFailedRun r.testRuns
      where
        isFailedRun (TestRunCompleted c) = not c.passed
        isFailedRun (TestRunErrored _) = True
        isFailedRun (TestRunning _ _) = False

    buildSummary tz r =
        let errs = length $ filter ((== SError) . (.severity)) r.diagnostics
            warns = length $ filter ((== SWarning) . (.severity)) r.diagnostics
            ts = toText $ "— " <> formatTime defaultTimeLocale "%H:%M:%S" (utcToLocalTime tz r.completedAt)
            stats = toText $ "(" <> show r.moduleCount <> " modules, " <> formatDuration r.duration <> ")"
        in  if null r.diagnostics then
                "All good. " <> stats <> " " <> ts
            else
                show errs <> " error(s), " <> show warns <> " warning(s) " <> stats <> " " <> ts


completionSummary :: TestRunCompletion -> Text
completionSummary c = statusText <> maybe "" (\d -> " (" <> formatDuration d <> ")") c.duration
  where
    statusText
        | null c.testCases = if c.passed then "passed" else "failed"
        | otherwise =
            let total = length c.testCases
                failedCount = length $ filter isFailedCase c.testCases
            in  if failedCount == 0 then
                    "passed (" <> show total <> ")"
                else
                    show failedCount <> "/" <> show total <> " failed"
    isFailedCase (TestCase _ (TestCaseFailed _)) = True
    isFailedCase _ = False


showLog
    :: ( Console :> es
       , Delay :> es
       , FileSystem :> es
       )
    => FilePath -> FollowMode -> Eff es ()
showLog path followMode = do
    exists <- doesFileExist path
    if not exists then
        Console.putTextLn $ "Log file does not exist yet: " <> toText path
    else case followMode of
        Follow -> followFile path Console.putStr
        NoFollow -> readFileLbs path >>= Console.putStr . BSL.toStrict


showTests
    :: ( Console :> es
       , Exit :> es
       , File :> es
       , Reader SocketPath :> es
       , UnixSocket :> es
       )
    => TestOptions -> Eff es ()
showTests opts = do
    SocketPath sockPath <- ask
    result <-
        case opts.wait of
            WaitForBuild -> queryStatusWait sockPath
            ShowCurrent -> queryStatus sockPath
    case result of
        Left err -> Console.putTextLn $ "Error: " <> err
        Right state ->
            case state.phase of
                Building _ -> Console.putStrLn "Build in progress, no test results yet."
                Restarting -> Console.putStrLn "Daemon restarting, no test results yet."
                Testing r -> renderTestRuns r.testRuns
                Done r -> renderTestRuns r.testRuns
                BuildFailed msg -> reportBuildFailed msg
  where
    renderTestRuns [] = Console.putStrLn "No test results."
    renderTestRuns testRuns
        | null runs = do
            Console.putStrLn "All passed."
            mapM_ (Console.putTextLn . ("  " <>) . testRunTarget) testRuns
        | otherwise = do
            mapM_ printTestOutput runs
            when (any isFailed runs) exitFailure
      where
        runs =
            if opts.failedOnly then
                filter isFailed testRuns
            else
                testRuns

    isFailed (TestRunCompleted c) = not c.passed
    isFailed (TestRunErrored _) = True
    isFailed (TestRunning _ _) = False

    testRunTarget (TestRunning t _) = t
    testRunTarget (TestRunErrored e) = e.target
    testRunTarget (TestRunCompleted c) = c.target

    printTestOutput tr = case tr of
        TestRunning t Nothing ->
            Console.putTextLn $ t <> "  running..."
        TestRunning t (Just p) ->
            Console.putTextLn $ t <> "  running... (" <> show p.compiled <> "/" <> show p.total <> ")"
        TestRunErrored e ->
            Console.putTextLn $ e.target <> "  error: " <> e.message
        TestRunCompleted c -> do
            Console.putTextLn $ c.target <> "  " <> completionSummary c
            if opts.failedOnly then
                if null c.testCases then do
                    Console.putTextLn "  (unrecognised test runner format — showing full output)"
                    mapM_ (Console.putTextLn . ("  " <>)) (stripGhciNoise (lines c.output))
                else
                    mapM_ printFailedCase (filter isCaseFailed c.testCases)
            else
                mapM_ (Console.putTextLn . ("  " <>)) (stripGhciNoise (lines c.output))

    isCaseFailed (TestCase _ (TestCaseFailed _)) = True
    isCaseFailed _ = False

    printFailedCase tc = do
        Console.putTextLn $ "  " <> tc.description
        case tc.outcome of
            TestCaseFailed details ->
                mapM_ (Console.putTextLn . ("    " <>)) (T.lines details)
            TestCasePassed -> pure ()


showSource
    :: ( Console :> es
       , File :> es
       , Reader SocketPath :> es
       , UnixSocket :> es
       )
    => [SourceQuery]
    -> Eff es ()
showSource queries = do
    SocketPath sockPath <- ask
    result <- querySource sockPath queries
    case result of
        Left err -> Console.putTextLn $ "Error: " <> err
        Right results -> renderSourceResults results