{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module DebugUtil where

import Control.Monad
import Data.Time.Clock
import Data.List
import Text.Printf
import GHC.Conc (threadStatus,ThreadStatus(..))
#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent.Lifted
import GHC.Conc                  (labelThread)
#endif

showReport :: [(String,String)] -> String
showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs

showColumns :: [[String]] -> String
showColumns rows = do
    let cols = transpose rows
        ws = map (maximum . map (succ . length)) cols
    fs <- rows
    _ <- take 1 fs -- Guard against empty rows so that 'last' is safe.
    "  " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n"


threadReport :: Bool -- ^ False to summarize search threads.
                -> IO String
threadReport want_ss = do
    threads <- threadsInformation
    tm <- getCurrentTime
    let (ss,ts) = partition (("search" `isPrefixOf`) . lbl . snd)
                            threads
    r <- forM (if want_ss then threads else ts) $ \(tid,PerThread{..}) -> do
        stat <- threadStatus tid
        let showStat (ThreadBlocked reason) = show reason
            showStat stat                   = show stat
        return [show lbl,show (diffUTCTime tm startTime),showStat stat]
    return $ unlines [ showColumns r
                     , (if want_ss then "  There are " else "  and ")
                        ++ show (length ss) ++ " search threads." ]