module Cabal.Matrix.Tui.Flavor ( FlavorState , initFlavorState , flavorFromRecording , TimerEvent(..) , flavorHandleTimerEvent , flavorHandleSchedulerEvent , OutputState(..) , initOutputState , outputWidget , outputHandleEvent , outputKeybinds , matrixCellWidth , matrixCellHeight , cellWidget ) where import Cabal.Matrix.CabalArgs import Cabal.Matrix.ProcessRunner import Cabal.Matrix.Record import Cabal.Matrix.Scheduler import Cabal.Matrix.Tui.Common import Data.Bifunctor import Data.ByteString (ByteString) import Data.Function import Data.List import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Graphics.Vty import System.Exit data StepState = StepState { cmdline :: NonEmpty Text , started :: Bool , revOutput :: [(OutputChannel, ByteString)] , lastTickOutputCount :: !Int , outputCount :: !Int , exit :: Maybe ExitCode } initStepState :: NonEmpty Text -> StepState initStepState cmdline = StepState { cmdline , started = False , revOutput = [] , lastTickOutputCount = 0 , outputCount = 0 , exit = Nothing } stepFromRecording :: StepResult -> StepState -> StepState stepFromRecording result ss = ss { started = True , revOutput = reverse $ second Text.encodeUtf8 <$> result.output , exit = Just result.exitCode } statusColor :: StepState -> Color statusColor ss = case ss.exit of _ | not ss.started -> white Nothing -> brightYellow Just ExitSuccess -> brightGreen Just (ExitFailure _) -> brightRed stepOutputWidget :: DisplayRegion -> StepState -> Image stepOutputWidget (width, height) ss = header <-> output where commandText = "Command: " headerBg = defAttr `withBackColor` blue status = headerBg `withForeColor` statusColor ss header = vertCat [ horizCat $ padToCommonHeight [ ( headerBg , ' ' , text' (headerBg `withForeColor` brightYellow) commandText ) , ( headerBg , ' ' , vertCat [ resizeWidthFill headerBg ' ' (width - safeWctwidth commandText) $ text' headerBg line | line <- wrap (width - safeWctwidth commandText) $ Text.unwords $ NonEmpty.toList ss.cmdline ] ) ] , resizeWidthFill headerBg ' ' width $ text' (headerBg `withForeColor` brightYellow) "Status: " <|> case ss.exit of _ | not ss.started -> text' status "Pending" Nothing -> text' status "Running" Just ExitSuccess -> text' status "Completed successfully" Just (ExitFailure code) -> text' status $ "Failed with exit code " <> Text.pack (show code) , charFill (headerBg `withForeColor` brightYellow) borderEW width 1 ] output = resize width (height - imageHeight header) $ vertCat [ text' defAttr line | line <- reverse . take (height - imageHeight header) . reverse $ wrap width $ Text.concat $ Text.decodeUtf8Lenient . snd <$> reverse ss.revOutput ] data TimerEvent = TimerEvent stepHandleSchedulerEvent :: SchedulerMessage -> StepState -> StepState stepHandleSchedulerEvent ev ss = case ev of OnStepStarted{} -> ss { started = True } OnStepFinished{ exitCode } -> ss { exit = Just exitCode } OnOutput{ channel, output } -> ss { revOutput = (channel, output):ss.revOutput , outputCount = ss.lastTickOutputCount + 1 } OnDone{} -> ss stepHandleTimerEvent :: TimerEvent -> StepState -> StepState stepHandleTimerEvent ev ss = case ev of TimerEvent -> ss { lastTickOutputCount = ss.outputCount } type FlavorState = PerCabalStep StepState initFlavorState :: PerCabalStep (NonEmpty Text) -> FlavorState initFlavorState = fmap initStepState flavorFromRecording :: FlavorResult -> FlavorState -> FlavorState flavorFromRecording result fs = tabulateCabalStep' \step -> maybe id stepFromRecording (indexCabalStep result.steps step) (indexCabalStep fs step) flavorHandleSchedulerEvent :: SchedulerMessage -> FlavorState -> FlavorState flavorHandleSchedulerEvent ev fs = case ev of OnStepStarted{ step } -> modifyCabalStep step (stepHandleSchedulerEvent ev) fs OnStepFinished{ step } -> modifyCabalStep step (stepHandleSchedulerEvent ev) fs OnOutput{ step } -> modifyCabalStep step (stepHandleSchedulerEvent ev) fs OnDone{} -> fs flavorHandleTimerEvent :: TimerEvent -> FlavorState -> FlavorState flavorHandleTimerEvent ev fs = tabulateCabalStep' \step -> stepHandleTimerEvent ev $ indexCabalStep fs step newtype OutputState = OutputState { selectedStep :: CabalStep } initOutputState :: FlavorState -> OutputState initOutputState fs = OutputState { selectedStep = fromMaybe FullBuild $ find (\step -> indexCabalStep fs step & \ss -> ss.started && ss.exit /= Just ExitSuccess) [minBound..maxBound] } outputWidget :: DisplayRegion -> PerCabalStep Bool -> FlavorState -> OutputState -> Image outputWidget (width, height) enabledSteps fs os = tabSwitcher <-> output where stepName = \case DryRun -> "Planning" OnlyDownload -> "Download" OnlyDependencies -> "Dependencies" FullBuild -> "Build" tabSwitcher = horizCat [ char defAttr ' ' <|> text' (if step == os.selectedStep then defAttr `withBackColor` blue else defAttr `withBackColor` brightBlack) (if ss.started && isNothing ss.exit then stepName step <> " " <> outputSpinner ss else stepName step) | step <- [minBound..maxBound] , indexCabalStep enabledSteps step || step == os.selectedStep , let ss = indexCabalStep fs step ] output = stepOutputWidget (width, height - imageHeight tabSwitcher) (indexCabalStep fs os.selectedStep) outputSpinner :: StepState -> Text outputSpinner ss = Text.singleton $ "|/-\\" !! (ss.outputCount `mod` 4) outputHandleEvent :: PerCabalStep Bool -> Event -> OutputState -> OutputState outputHandleEvent enabledSteps ev os = case ev of -- Make sure to do something sensible if all steps are disabled EvKey KLeft _ -> os { selectedStep = fromMaybe os.selectedStep $ listToMaybe [ step | step <- reverse [minBound..maxBound] , indexCabalStep enabledSteps step , step < os.selectedStep ] } EvKey KRight _ -> os { selectedStep = fromMaybe os.selectedStep $ listToMaybe [ step | step <- [minBound..maxBound] , indexCabalStep enabledSteps step , step > os.selectedStep ] } _ -> os outputKeybinds :: [(Text, Text)] outputKeybinds = [ (Text.pack [triangleW, triangleE], "switch build steps") ] matrixCellWidth :: Int matrixCellWidth = 10 matrixCellHeight :: Int matrixCellHeight = 1 cellWidget :: Bool -> Maybe FlavorState -> Image cellWidget focused Nothing = charFill (if focused then defAttr `withBackColor` brightBlack else defAttr) ' ' matrixCellWidth matrixCellHeight cellWidget focused (Just pcs) = resizeWidthFill attr ' ' matrixCellWidth if | Just ExitSuccess <- pcs.fullBuild.exit -> go FullBuild "build ok" | Just (ExitFailure _) <- pcs.fullBuild.exit -> go FullBuild "build fail" | pcs.fullBuild.started -> go FullBuild $ "build " <> outputSpinner pcs.fullBuild | Just ExitSuccess <- pcs.onlyDependencies.exit -> go OnlyDependencies "deps ok" | Just (ExitFailure _) <- pcs.onlyDependencies.exit -> go OnlyDependencies "deps fail" | pcs.onlyDependencies.started -> go OnlyDependencies $ "deps " <> outputSpinner pcs.onlyDependencies | Just ExitSuccess <- pcs.onlyDownload.exit -> go OnlyDownload "DL ok" | Just (ExitFailure _) <- pcs.onlyDownload.exit -> go OnlyDownload "DL fail" | pcs.onlyDownload.started -> go OnlyDownload $ "DL " <> outputSpinner pcs.onlyDownload | Just ExitSuccess <- pcs.dryRun.exit -> go DryRun "plan ok" | Just (ExitFailure _) <- pcs.dryRun.exit -> go DryRun "no plan" | pcs.dryRun.started -> go DryRun $ "plan " <> outputSpinner pcs.dryRun | otherwise -> text' attr "..." where attr = if focused then defAttr `withBackColor` blue else defAttr go step = text' $ attr `withForeColor` if -- A failure to --dry-run, that is, to solve package constraints is often -- not considered a failure. Rather it indicates that the package bounds -- are set up correctly. | DryRun <- step , Just (ExitFailure _) <- (indexCabalStep pcs step).exit -> cyan | otherwise -> statusColor (indexCabalStep pcs step)