module Report where

import Control.Arrow
import Control.Monad.Error
import Data.Function
import Data.List
import Data.List.Split
import Data.Maybe
import Data.DateTime( formatDateTime, startOfTime )
import qualified Data.Map as Map
import qualified Text.Tabular          as Tab
import System.Directory
import System.FilePath
import System.IO

import Definitions
import Graph
import Shellish hiding ( run )
import Standard
import TabularRST as TR
import qualified Data.ByteString.Char8 as BS

-- ----------------------------------------------------------------------
-- tables
-- ----------------------------------------------------------------------

type BenchmarkTable = Tab.Table String String String

tabulateRepo :: Formatter -> RepoTable -> Tab.Table String String String
tabulateRepo format repo = Tab.Table rowhdrs colhdrs rows
 where
  rowhdrs = Tab.Group Tab.NoLine $ map Tab.Header (rtRows repo)
  colhdrs = Tab.Group Tab.SingleLine $ map Tab.Header $
              concatMap (format myundefined . ColHeader) $ rtColumns repo
  myundefined = error "Formatting is undefined for column headers"
  rows = map formatRow $ rtTable repo
  formatRow (tu, rs) = concatMap (fmt tu) rs
  fmt tu (Just mt) = format tu (Cell mt)
  fmt tu Nothing = format tu MissingCell

-- ----------------------------------------------------------------------
-- timings files
-- ----------------------------------------------------------------------

readAllTimings :: IO [[(Test a, Maybe MemTimeOutput)]]
readAllTimings = do
  rdir  <- resultsDir
  tdirs <- filter isTimingFile `fmap` getDirectoryContents rdir
  let pstamps = map dropExtension tdirs
  mapM readTimingsForParams pstamps
 where
  isTimingFile f = takeExtension f == ".timings"

unknownBinary x =
  TestBinary { binCommand = x, binVersionString = "unknown"
             , binDate = startOfTime, binGHC = "unknown", binVCS = VCSDarcs
             , binContext = BS.empty }

-- | Map an sha1 of darcs binary into the original binary description.
readInfos :: String -> (String -> TestBinary)
readInfos bits = \x -> case lookup x table of
  Nothing -> unknownBinary x
  Just b -> b
  where table' = sortBy order (case reads bits of
                                  [] -> []
                                  ((x,_):_) -> x)
        ids = [ id | (id:_:_) <- group . sort $ map (binCommand . snd) table' ]
        fixid n id ((sha, bin):rem)
          | binCommand bin == id = (sha, bin { binCommand = id ++ " " ++ show n }) :
                                       fixid (n + 1) id rem
          | otherwise = (sha, bin) : fixid n id rem
        fixid _ _ [] = []
        table = (foldl (.) id (map (fixid 0) ids)) table'
        order (_, x) (_, y) = case compare (binVersion x) (binVersion y) of
          EQ -> compare (binDate x) (binDate y)
          ord -> ord

readTimingsForParams :: String -> IO [(Test a, Maybe MemTimeOutput)]
readTimingsForParams pstamp = do
  rdir  <- resultsDir
  let pdir = rdir </> pstamp <.> "timings"
      ifile = rdir </> pstamp <.> "info"
  infos <- (readInfos `fmap` readFile ifile) `catch` \_ -> do
    hPutStrLn stderr $ "WARNING: Could read " ++ ifile
    return unknownBinary
  tfiles   <- filter notJunk `fmap` getDirectoryContents pdir
  entries  <- concat `fmap` mapM parseTimingsFile (map (pdir </>) tfiles)
  return . map (process infos) . Map.toList . Map.fromListWith (++) . map (second (:[])) $ entries
 where
  notJunk = not . (`elem` [".",".."])

process :: (String -> TestBinary)
           -> ((String, String, String), [MemTime]) -> (Test a, Maybe MemTimeOutput)
process infos ((repo, binhash, bm), times) = (key, val)
 where
   key = Test (Description bm) (mkTr repo) (infos binhash)
   val = Just $ mkMemTimeOutput times
   mkTr n = TestRepo n (guessCoreName n) n Nothing [] []

guessCoreName :: String -> String
guessCoreName n =
  case [ n `chop` (' ':s) | s <- suffixes, s `isSuffixOf` n ] of
   []    -> n
   (h:_) -> h
 where
  x `chop` s = take (length x - length s) x
  suffixes   = sortBy (compare `on` (negate . length)) -- longest suffixes first
             $ map vShortName allVariants

type TimingsFileEntry = ((String,String,String),MemTime)

parseTimingsFile :: FilePath -> IO [TimingsFileEntry]
parseTimingsFile tf = do
  ms <- (map parseLine . lines) `fmap` readFile tf
  let unknowns = length $ filter isNothing ms
  when (unknowns > 0) $
    hPutStrLn stderr $ "Warning: could not understand " ++ show unknowns ++ " lines in " ++ tf
  return (catMaybes ms)

parseLine :: String -> Maybe TimingsFileEntry
parseLine l =
 case wordsBy (== '\t') l of
  [ repo, dbin, bm, mem, time ] -> Just ((repo, dbin, bm), memtime time mem)
  _ -> Nothing
 where
  memtime t m = MemTime (toRational (read m :: Float)) (read t)

-- ----------------------------------------------------------------------
-- reports
-- ----------------------------------------------------------------------

renderMany :: [(Test a, Maybe MemTimeOutput)] -> Command ()
renderMany results = do
  echo . unlines $
   [ "Benchmark Results"
   , "====================================================="
   , ""
   , machine_details
   , ""
   , "How to read these tables"
   , "====================================================="
   , ""
   , "NB: times are reported as mean + 1 std deviation"
   , ""
   , def "?x" "less than  5 runs used"
   , def "~x" "less than 20 runs used"
   , def "sdev" "std deviation"
   , descriptions_of_variants
   , ""
   , binary_details
   , ""
   , "Timing Graphs"
   , "===================================================="
   , ""
   , intercalate "\n" (map showG t_graphs)
   , "Timings"
   , "===================================================="
   , ""
   , intercalate "\n" (map showT t_tables)
   , "Memory Graphs"
   , "===================================================="
   , ""
   , intercalate "\n" (map showG m_graphs)
   , "Memory"
   , "===================================================="
   , ""
   , intercalate "\n" (map showT m_tables)
   ]
 where
  tables = repoTables benchmarks results
  --
  machine_details = intercalate "\n" $
    map detail [ "Machine description", "Year", "CPU", "Memory", "Hard disk", "Notes" ]
  detail k = k ++ "\n    *Replace Me*"
  --
  descriptions_of_variants = intercalate "\n" $
    map (describe . toVariant) [ OptimizePristineVariant ]
  describe v = def (vSuffix v) (vDescription v ++ " variant")
  def k v = "* " ++ k ++ " = " ++ v
  --
  repoTuple tabulate repo = (rtRepo repo, tabulate repo)
  t_tables = map (repoTuple $ tabulateRepo formatTimeResult) tables
  m_tables = map (repoTuple $ tabulateRepo formatMemoryResult) tables
  showT (r,t) = intercalate "\n" [ r
                                 , replicate (length r) '-'
                                 , ""
                                 , TR.render id id id t ]
  --
  t_graphs = map (repoTuple graphRepoTime) tables
  m_graphs = map (repoTuple graphRepoMemory) tables
  showG (r,gs) = intercalate "\n" $ [ r
                                    , replicate (length r) '-'
                                    , ""
                                    ] ++ (map imgDirective gs) ++ [""]
  imgDirective = (".. image:: " ++)
  binaries = map head . group . sort $ [ bin | (Test _ _ bin, _) <- results ]
  --
  binary_details = unlines $ map describe_bin binaries
  describe_bin bin = padl 12 (binCommand bin ++ ": ") ++
                     binVersionString bin ++ ",\n" ++ (replicate 12 ' ') ++
                     (formatDateTime "%Y-%m-%d %H:%M:%S" $ binDate bin) ++
                     ", GHC " ++ binGHC bin
  padr n x = x ++ pad n x
  padl n x = pad n x ++ x
  pad n x = take (n - length x) (repeat ' ')

printCumulativeReport :: Command ()
printCumulativeReport = do
  ts <- liftIO readAllTimings
  mapM_ renderMany ts -- TODO: split this into sections for each param stamp

-- | For each repository, the benchmarks that we have enough data for
sufficientData :: [(Test a, Maybe MemTimeOutput)] -> [ (String, [String]) ]
sufficientData results =
  map (rtRepo &&& missingPoints) tables
 where
  tables = repoTables benchmarks results
  missingPoints t = [ d | (d,mts) <- zip (rtRows t) (rtTable t), all enough (snd mts) ]
  --
  enough (Just mt) | mtSampleSize mt >= 20 = True -- TODO: avoid duplication with formatTimeResult
  enough _ = False