{-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns, ScopedTypeVariables, TypeOperators #-}

module Development.Bake.Server.Stats(
    stats,
    record, recordIO
    ) where

import Control.DeepSeq
import Control.Applicative
import Control.Monad
import Development.Bake.Core.Type
import Development.Bake.Server.Brain
import Database.SQLite.Simple
import Data.IORef
import Data.Monoid
import Data.List.Extra
import General.HTML
import General.Extra
import Development.Bake.Server.Store
import GHC.Stats
import System.IO.Unsafe
import System.Time.Extra
import Control.Exception
import Numeric.Extra
import qualified Data.Map as Map
import Prelude


data Stat = Stat {statHistory :: [Double], statCount :: !Int, statSum :: !Double, statMax :: !Double}

instance Monoid Stat where
    mempty = Stat [] 0 0 0
    mappend (Stat x1 x2 x3 x4) (Stat y1 y2 y3 y4) = Stat (take 10 $ x1 ++ y1) (x2+y2) (x3+y3) (x4 `max` y4)


{-# NOINLINE recorded #-}
recorded :: IORef (Map.Map String Stat)
recorded = unsafePerformIO $ newIORef Map.empty

record :: NFData b => (a -> ([String], b)) -> a -> b
record f x = unsafePerformIO $ recordIO $ return $ f x

recordIO :: NFData a => IO ([String], a) -> IO a
recordIO x = do
    (d, (msg,x)) <- duration $ do x <- x; evaluate $ rnf x; return x
    forM_ (inits msg) $ \msg ->
        atomicModifyIORef recorded $ (,()) .  Map.insertWith mappend (unwords msg) (Stat [d] 1 d d)
    return x


stats :: Prettys -> Memory -> (Maybe Test -> HTML) -> IO HTML
stats Prettys{..} Memory{..} showTest = do
    recorded <- readIORef recorded
    getGCStatsEnabled <- getGCStatsEnabled
    stats <- if getGCStatsEnabled then Just <$> getGCStats else return Nothing
    rel <- relativeTime

    [Only (patchCount :: Int)] <- storeSQL store "SELECT count(*) FROM patch" ()
    [Only (stateCount :: Int)] <- storeSQL store "SELECT count(*) FROM state" ()
    [Only (runCount :: Int)] <- storeSQL store "SELECT count(*) FROM run" ()

    slowest :: [Only (Maybe Test) :. (Int, Seconds, Seconds, Seconds)] <- storeSQL store "SELECT test, count(*), avg(duration) as avg, sum(duration), max(duration) FROM run WHERE test NOT IN (SELECT test FROM skip) GROUP BY test ORDER BY avg DESC LIMIT 25" ()
    [slowestAll :: (Int, Seconds, Seconds, Seconds)] <- storeSQL store "SELECT count(*), avg(duration) as avg, sum(duration), max(duration) FROM run" ()
    rejections :: [(Maybe Test, Int)] <- storeSQL store "SELECT test, count(*) AS n FROM reject WHERE test IS NULL OR test NOT IN (SELECT test FROM skip) GROUP BY test ORDER BY n DESC LIMIT 10" ()

    now <- getCurrentTime
    let periods = [addSeconds (negate x*24*60*60) now | x <- [1,7,30,365]]
    let one [Only x] = x
        one _ = 0
    plausibleCount :: [Int] <- forM periods $ \p -> one <$> storeSQL store "SELECT count(*) FROM patch WHERE plausible IS NOT NULL AND queue > ?" (Only p)
    plausibleAvg :: [Double] <- forM periods $ \p -> one <$> storeSQL store "SELECT ifnull(avg(julianday(plausible)-julianday(queue)),0.0) FROM patch WHERE plausible IS NOT NULL AND queue > ?" (Only p)
    percentiles <- forM [100,95,90,80,75,50,25,10,0] $ \perc -> (perc,) <$> do
        forM (zip periods plausibleCount) $ \(p,count) -> do
            let n = min (count - 1) $ ((count * perc) `div` 100)
            one <$> storeSQL store "SELECT julianday(plausible)-julianday(queue) AS x FROM patch WHERE plausible IS NOT NULL AND queue > ? ORDER BY x ASC LIMIT ?, 1" (p,n)

    deadSkip :: [(Test,String)] <- storeSQL store "SELECT skip.test, skip.comment FROM skip WHERE skip.test NOT IN (SELECT DISTINCT run.test FROM run WHERE run.test IS NOT NULL AND run.start > ?) ORDER BY test ASC" $ Only $ addSeconds (-7*24*60*60) now
    aliveSkip :: [(Test,String,Int, Int, Seconds)] <- storeSQL store "SELECT run.test, skip.comment, sum(run.success) AS good, count(*)-sum(run.success) AS bad, avg(run.duration) FROM run, skip WHERE run.test = skip.test AND run.duration IS NOT NULL AND run.start > ? GROUP BY skip.test ORDER BY bad ASC, good DESC" $ Only $ addSeconds (-7*24*60*60) now

    return $ do
        p_ $ str_ $ "Patches = " ++ show patchCount ++ ", states = " ++ show stateCount ++ ", runs = " ++ show runCount

        header_ "sampled" "Sampled statistics"
        let ms x = show (ceiling $ x * 1000 :: Integer)
        table ["Counter","Count","Mean (ms)","Sum (ms)","Max (ms)","Last 10 (ms)"]
            [ (if null name then i_ $ str_ "All" else str_ name) :
              map str_ [show statCount, ms $ statSum / intToDouble statCount, ms statSum
                       ,ms statMax, unwords $ map ms statHistory] 
            | (name,Stat{..}) <- Map.toAscList recorded]

        header_ "slowest" "Slowest tests (top 25)"
        table ["Test","Count","Mean","Sum","Max"] $
            let f name (count, avg, sum, max) = name : map str_ [show count, showDuration avg, showDuration sum, showDuration max]
            in f (i_ $ str_ "All") slowestAll : [f (showTest test) x | (Only test :. x) <- slowest]

        header_ "rejects" "Most common rejection tests (top 10)"
        table ["Test","Rejections"] [[showTest t, str_ $ show x] | (t, x) <- rejections]

        header_ "plausible" "Speed to plausible"
        table ["Plausible","Last day","Last week","Last month","Last year"] $
            let f x = str_ $ showDuration $ x*24*60*60
                perc 100 = "Maximum"
                perc 0 = "Minimum"
                perc x = show x ++ "% within" in
            (str_ "Count" : map (str_ . show) plausibleCount) :
            (str_ "Average" : map f plausibleAvg) :
            [str_ (perc p) : map f xs | (p,xs) <- percentiles]

        header_ "skip-stale" "Stale skips (not run in a week)"
        table ["Test","Comment"]
            [[showTest $ Just t, str_ c] | (t,c) <- deadSkip]

        header_ "skip-alive" "Alive skips (last week)"
        table ["Test","Comment","Successes","Failures","Avg duration"] $
            [[showTest $ Just t, str_ c, str_ $ show s, str_ $ show f, str_ $ showDuration d] | (t,c,s,f,d) <- aliveSkip]

        header_ "ghc-stats" "GHC statistics"
        case stats of
            Nothing -> p_ $ str_ "No GHC stats, rerun with +RTS -T"
            Just x@GCStats{..} -> do
                ul_ $ do
                    li_ $ str_ $ "Uptime of: " ++ showDuration wallSeconds
                    li_ $ str_ $ "Haskell memory usage: " ++ show peakMegabytesAllocated ++ "Mb"
                    li_ $ str_ $ "CPU time: " ++ showDuration cpuSeconds ++
                          " (mutator: " ++ showDuration mutatorCpuSeconds ++ ", GC: " ++ showDuration gcCpuSeconds ++ ")"
                pre_ $ str_ $ replace ", " "\n" $ takeWhile (/= '}') $ drop 1 $ dropWhile (/= '{') $ show x


table :: [String] -> [[HTML]] -> HTML
table cols body = table_ $ do
    thead_ $ tr_ $ mconcat $ map (td_ . str_) cols
    tbody_ $ mconcat $ [tr_ $ mconcat $ map td_ x | x <- body]