Record.hs

module Cabal.Matrix.Record
  ( RunOptions(..)
  , record
  , StepResult(..)
  , FlavorResult(..)
  ) where

import Cabal.Matrix.CabalArgs
import Cabal.Matrix.Cli
import Cabal.Matrix.Matrix
import Cabal.Matrix.ProcessRunner
import Cabal.Matrix.Rectangle qualified as Rectangle
import Cabal.Matrix.Scheduler
import Control.Concurrent
import Control.Monad
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Function
import Data.IORef
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Primitive
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.IO qualified as Text
import System.Exit
import System.IO


data StaticFlavorResult = StaticFlavorResult
  { flavor :: Map Text Text
  , cmdlines :: PerCabalStep (NonEmpty Text)
  }

data StepState = StepState
  { started :: Bool
  , revOutput :: [(OutputChannel, ByteString)]
  , exit :: Maybe ExitCode
  }

collapseOutput :: [(OutputChannel, ByteString)] -> [(OutputChannel, ByteString)]
collapseOutput = map (\grp -> (fst $ NonEmpty.head grp, foldMap snd grp))
  . NonEmpty.groupBy ((==) `on` fst)

record :: Matrix -> RunOptions -> IO [FlavorResult]
record matrix options = do
  schedulerConfig <- getSchedulerConfig options
  let
    !flavors = Rectangle.rows matrix
    !statics = arrayFromListN (sizeofArray flavors)
      [ StaticFlavorResult
        { flavor = Map.fromList $ mapMaybe sequenceA pairs
        , cmdlines = tabulateCabalStep' \step
          -> renderCabalArgs $ mkCabalArgs schedulerConfig step flavor
        }
      | (flavor, pairs) <- Rectangle.toRowMajor matrix
      ]

  results <- flip traverseArrayP flavors
    \_ -> sequenceA $ tabulateCabalStep' \_ -> newIORef StepState
      { started = False
      , revOutput = []
      , exit = Nothing
      }
  doneVar <- newEmptyMVar
  _ <- startScheduler schedulerConfig flavors
      \case
        OnDone -> putMVar doneVar ()
        OnStepStarted{ flavorIndex, step } -> atomicModifyIORef'
          (indexCabalStep (indexArray results flavorIndex) step)
          \state -> (state { started = True }, ())
        OnStepFinished{ flavorIndex, step, exitCode } -> do
          atomicModifyIORef'
            (indexCabalStep (indexArray results flavorIndex) step)
            \state -> (state { exit = Just exitCode }, ())
          Text.hPutStrLn stderr $ prettyStepFinished
            (snd $ Rectangle.indexRow matrix flavorIndex) step exitCode
        OnOutput{ flavorIndex, step, channel, output } -> atomicModifyIORef'
          (indexCabalStep (indexArray results flavorIndex) step)
          \state
            -> (state { revOutput = (channel, output):state.revOutput }, ())

  takeMVar doneVar
  frozenResults <- traverseArrayP (traverse readIORef) results
  pure $ zipWith mkFlavorResult (toList statics) (toList frozenResults)

prettyStepFinished :: [(Text, Maybe Text)] -> CabalStep -> ExitCode -> Text
prettyStepFinished flavor step exit
  = prettyStep <> " " <> prettyExit <> " for {" <> prettyFlavor <> "}"
  where
    prettyStep = case step of
      DryRun -> "plan"
      OnlyDownload -> "download"
      OnlyDependencies -> "dependencies"
      FullBuild -> "build"
    prettyExit = case exit of
      ExitSuccess -> "ok"
      ExitFailure _ -> "failed"
    prettyFlavor = Text.intercalate ","
      [ Text.pack (show key) <> ": " <> Text.pack (show value)
      | (key, Just value) <- flavor
      ]

-- | The ultimate result of having completed a single step of a single flavor.
data StepResult = StepResult
  { cmdline :: NonEmpty Text
  , output :: [(OutputChannel, Text)]
  , exitCode :: ExitCode
  }

data FlavorResult = FlavorResult
  { flavor :: Map Text Text
  , steps :: PerCabalStep (Maybe StepResult)
  }

mkFlavorResult :: StaticFlavorResult -> PerCabalStep StepState -> FlavorResult
mkFlavorResult StaticFlavorResult{..} pcs = FlavorResult
  { flavor
  , steps = tabulateCabalStep' mk
  }
  where
    mk step
      | !state <- indexCabalStep pcs step
      , !cmdline <- indexCabalStep cmdlines step
      = do
        guard state.started
        exitCode <- state.exit
        let
          output = map (fmap Text.decodeUtf8Lenient)
            $ collapseOutput $ reverse state.revOutput
        pure StepResult{..}