-----------------------------------------------------------------------------
-- |
-- Module      :  gen-report
-- Copyright   :  (c) Don Stewart 2007
-- License     :  BSD3-style (see LICENSE)
-- 
-- Maintainer  :  dons@cse.unsw.edu.au
-- Stability   :  experimental
--
-----------------------------------------------------------------------------

import Control.Exception
import Control.Monad
import Data.List
import Data.List
import Data.Maybe
import System.Environment
import System.Process
import System.Time
import System.IO
import Text.Printf
import Text.XHtml.Transitional

import Numeric

import Results -- contains shared datatypes: Results, Error, Version

------------------------------------------------------------------------

main = do
    fs <- getArgs
    arch  <- run "bin/arch"
    [machine] <- run "uname -m"
    cpu   <- if length (words machine) > 1 then fmap head (run "uname -p")
             else return machine

    baseUrl <- getEnv "PUBLISH_URL"
    let errUrl = baseUrl++"/"++cpu++"/logs/"

    rs <- forM fs $ \f -> do s <- readFile f
                             length s `seq` return ()
                             v <- readIO s
                             return $! normalise v

    vs <- handle (const $ return []) (read `fmap` readFile "versions.db")
    time <- getClockTime
    start <- handle (const $ return []) (readFile "start.txt")
    end   <- handle (const $ return []) (readFile "finished.txt")
    putStr . showHtml $ mkReport time start end arch baseUrl errUrl vs rs

--
-- move all attributes into this style sheet
--
top baseUrl = header $
        (thetitle (toHtml "nobench: Haskell implementation shootout")) +++
        ( (thelink noHtml) ! [ rel "stylesheet"
                               , href (baseUrl++"/results.css")
                               , thetype "text/css" ])


--
-- drop non-significant digits from the doubles
--
normalise :: Results -> Results
normalise c@(Results { results = rs }) = c { results = map norm rs }
  where
    norm x@(s,r) = case r of
        Left _  -> x
        Right d -> (s, Right $ read (showFFloat (Just 2) d []))-- I'm a starving student

--
-- raw data
--
mkReport :: ClockTime 
          -> String 
          -> String 
          -> [String] 
          -> String 
          -> String 
          -> [Version] -> [Results] -> Html
mkReport time start end arch baseUrl errUrl vs s = top baseUrl +++ (body $

    center (
    (h2 (toHtml (hotlink baseUrl
            (toHtml "nobench: haskell implementation shootout"))))
        )
    +++
    (table $ (tr (td (toHtml $ "Results from " ++ show time )))
            +++
            (tr (td (toHtml $ "Run started at: "++ start)))
            +++
            (tr (td (toHtml $ "Finished at: "++ end))))
    +++

    (scores (table $
        (concatHtml
          ((flip map) groups ( \rs ->
            let category_results = sortBy (\a b -> test a `compare` test b) rs
            in

            (tr
                (concatHtml
                  ((td $ categoryTag (toHtml $ category (head category_results))
                --   ! [colspan ((length compilers)+1)]
                  ): map (td . pprCompiler) compilers))
            )
            +++
            (concatHtml (map (tr.toRow) category_results))
            +++
            (tr (concatHtml $ (td (averageTag (toHtml "average"))) :
                       [ td (average (toHtml fmt))
                       | (_,r,passed,total) <- averages_per_compiler
                                                    (transpose (map calc_result category_results))
                       , let fmt :: String
                             fmt = case r of
                                 Nothing            -> printf "N/A (%d/%d)" passed total
                                 Just (low,gm,high) -> printf "%3.2f (%d/%d)" (gm / 100) (passed :: Int) (total :: Int)
                       ]
            ))
            +++(tr (td (toHtml "      ")))



          ))
        ) +++


--      (tr (td (toHtml ""))) +++
        (tr $ concatHtml (map td (toHtml "" : map pprCompiler compilers)))
        +++
        (tr $ (concatHtml $ (td (averageTag (toHtml "GRAND TOTAL"))) :
                   [ td (totalTag (toHtml fmt))
                   | (_,r,passed,total) <- averages_per_compiler results_per_compiler
                   , let fmt :: String
                         fmt = case r of
                             Nothing            -> printf "N/A (%d/%d)" passed total
                             Just (low,gm,high) -> printf "%3.2f (%d/%d)" (gm / 100) (passed :: Int) (total :: Int)
                   ]
        ))


    ))

    +++ br +++
    (table $ concatHtml $ [ tr (td (toHtml c) +++ td (toHtml s)) | Version c s <- vs ]))
    
    +++ br +++
    (table $ concatHtml $ [ tr (td (toHtml s)) | s <- arch ])

    +++

    p (
    toHtml "Generated by " +++ toHtml (hotlink "http://haskell.org/ghc/docs/latest/html/libraries/xhtml/Text-XHtml.html" (toHtml "Text.XHtml")))

  where

    results_per_prog :: [[((String, Either Error Double), Bool, Maybe Double)]]
    results_per_prog     = map calc_result s
    results_per_compiler = transpose results_per_prog

    -- -1 average +1 geometric mean over all tests
    averages_per_compiler s =
        [ (which_compiler, calc_gmsd rs, n, length rs)
        | results <- s
        , let ((which_compiler,_),_,_) = head results
        , let rs = map thd3 results
        , let n = length (catMaybes rs)
        ]

    groups    = groupBy (\a b -> category a == category b) s

    compilers = sort $ map fst (results $ head s) -- ordered alphabetically

    pprCompiler s = toHtml (hotlink urlc (toHtml s))
        where
            urlc = fromJust $ lookup (baseCompiler s)
                    [("ghc", "http://haskell.org/ghc")
                    ,("hbc", "http://www.cs.chalmers.se/~augustss/hbc/hbc.html")
                    ,("hug", "http://haskell.org/hugs")
                    ,("nhc", "http://haskell.org/nhc98")
                    ,("yhc", "http://haskell.org/haskellwiki/Yhc")
                    ,("jhc", "http://repetae.net/john/computer/jhc/")
                    ]
            baseCompiler = take 3 . basename
            basename = reverse . takeWhile (/='/') . reverse

   --   gms@(Just (low,gm,high)) = calc_gmsd (map thd3 rs')
    thd3 (_,_,a) = a

    toRow rs@(Results c url t _) = td (toHtml $ hotlink url (toHtml t)) +++
                                 (concatHtml $ map (pprNumber t) (calc_result rs))


    -- Colour in green the best result
    -- Colour in red any error
    pprNumber test ((compiler, Left err),_,_) = td $ case err of
        CompileError _ -> compileError . compileLink . toHtml $ pprError err
        RuntimeError _ -> runtimeError . runtimeLink . toHtml $ pprError err
        TimeoutError   -> timeoutError . toHtml $ pprError err
        DiffError    _ -> diffError    . runtimeLink . toHtml $ pprError err

      where
        runtimeLink s = toHtml $ hotlink (errUrl ++ test ++ "." ++ compiler ++ ".actual")  s
        compileLink s = toHtml $ hotlink (errUrl ++ test ++ "." ++ compiler ++ ".compile") s

    pprNumber _ ((which, Right d),  isbest   ,Just pcnt)
        = (td . (if isbest then bestTime
                           else if pcnt < 100
                                    then goodTime
                                    else id) . toHtml $
                (fmt :: String))
        where
            fmt = printf "%3.2f (%3.1f)" d (pcnt/100) -- could tag ones that are < 1.0

    -- actual string to display for each error
    pprError e = case e of
         CompileError _   -> "compile error"
         RuntimeError _   -> "runtime error"
         TimeoutError     -> "timeout"
         DiffError    _   -> "output error"

--
-- map types to css divs
--
-- the .css markup defines how to ppr these constructors
--
compileError x = thediv x ! [identifier "CompileError"]
runtimeError x = thediv x ! [identifier "RuntimeError"]
timeoutError x = thediv x ! [identifier "Timeout"     ]
diffError    x = thediv x ! [identifier "DiffError"   ]
bestTime     x = thediv x ! [identifier "Best"        ]
goodTime     x = id x -- thediv x ! [identifier "Best"        ]
categoryTag  x = thediv x ! [identifier "Category"    ]
totalTag     x = thediv x ! [identifier "Total" ]
averageTag   x = thediv x ! [identifier "AverageTag" ]

scores       x = thediv x ! [identifier "Scores" ]
average      x = thediv x ! [identifier "Average" ]


sndEither (_,Right a) (_,Right b) = a `compare` b
sndEither (_,Left  a) (_,Right b) = GT
sndEither (_,Right a) (_,Left  b) = LT
sndEither _         _             = EQ

{-

<table>
<th>
Test        ghc     ghc-old     hbc              ghci           nhc98   hugs    yhc
</th>
<tr>
bernouilli  ..      ..         Runtime error    Timeout         Compile error
<tr>
...

</table>

-}

------------------------------------------------------------------------
-- 
-- code from nofib-analyse.
--
-- Calculating geometric means and standard deviations

{-
This is done using the log method, to avoid needing really large
intermediate results.  The formula for a geometric mean is

        (a1 * .... * an) ^ 1/n

which is equivalent to 
  
        e ^ ( (log a1 + ... + log an) / n )

where log is the natural logarithm function.

Similarly, to compute the geometric standard deviation we compute the
deviation of each log, take the root-mean-square, and take the
exponential again: 

        e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n )

where lbar is the mean log,

        (log a1 + ... + log an) / n

This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do
not subtract 100 from gm before performing this calculation.

We therefore return a (low, mean, high) triple.

-}
type Percent = Double


calc_gmsd :: [Maybe Double] -> Maybe (Double, Double, Double)
calc_gmsd xs
    | null percentages = Nothing
    | otherwise
    = let   sqr x   = x * x
            len     = fromIntegral (length percentages)
            logs    = map log percentages
            lbar    = sum logs / len
            st_devs = map (sqr . (lbar-)) logs
            dbar    = sum st_devs / len
            gm      = exp lbar
            sdf     = exp (sqrt dbar)
      in Just
           ((gm/sdf), gm, (gm*sdf))
      where

    percentages = [ if x < 5 then 5 else x | Just x <- xs ]
    -- can't do log(0.0), so exclude zeros
    -- small values have inordinate effects so cap at -95%.


convert_to_percentage 0 _          = 100
convert_to_percentage base val  | val < 0.01 = convert_to_percentage base 0.01
convert_to_percentage base val = (val / base) * 100

-- annotate the raw data for each compiler with:
--  if it is the best time
--  its percentage of the best time
--
calc_result (Results c url t rs) =
    let a    = sortBy (\(n,_) (m,_) -> n `compare` m) rs
        base@(_,Right basetime) = case head a of
                (_,Right _) -> head a -- ghc
                _           -> head (tail a) -- backup
        best@(_,Right besttime) = head $ sortBy sndEither rs

    in [ (x, et =~ Right besttime, pcnt )
       | x@(_,et) <- a
       , let pcnt = case et of
       --       Left TimeoutError -> Just (convert_to_percentage basetime 1800 {- !!!timeout x 1.5 -})
                Left _       -> Nothing
                Right t      -> Just (convert_to_percentage besttime t)
       ]
       where
            Right x =~ Right y = abs (x - y) <= epsilon
                where epsilon = 0.05
            Left _  =~ _       = False

run s = do
    (ih,oh,eh,pid) <- runInteractiveCommand s
    hClose ih

    so <- hGetContents oh
    se <- hGetContents eh

    map length [so,se] `seq` return ()
    return (lines $ so ++ se)