content: {-# LANGUAGE DeriveGeneric, DeriveAnyClass, BangPatterns #-}
  
  module Report where
  
  import           Control.DeepSeq
  import           Control.Monad
  import           Criterion.IO
  import           Criterion.Types
  import           Data.List
  import qualified Data.Map                      as M
  import           Data.Maybe
  import           GHC.Generics
  import           Statistics.Types
  import           System.Directory
  import           System.FilePath
  import           Text.Printf
  import           Data.Bifunctor
  import           Data.Char
  
  -- | Map test names to test measures
  type Measures = M.Map String Measure
  
  data Measure = Measure
    { mTest :: String -- ^Test name, with the format <test-kind>/<test-obj>-<test-pkg>
    , mValue :: Double -- ^Execution time (in ms or bytes, depending on the test)
    } deriving (Show, Read, Eq, Generic, NFData, Ord)
  
  {- | 
  >>> import Data.List
  >>> let m = Measure "deserialization (time)/BinTree Direction-binary" 1989
  >>> let m2 = Measure "serialization (time)/BinTree Direction-binary" 1004
  >>> let m3 = Measure "size (bytes)/BinTree Direction-binary" 6291455
  >>> let m4 = Measure "size (bytes)/Cars-binary" 301455
  >>> let m5 = Measure "size (bytes)/Cars-flat" 300000
  >>> let ms = measures [m,m2,m3,m4,m5]
  
  >>> mKindPkg m
  ("deserialization (time)/BinTree Direction","binary")
  
  >>> mKindPkgVal m
  ("deserialization (time)/BinTree Direction",("binary",1989.0))
  
  >>> mKind m
  "deserialization (time)/BinTree Direction"
  
  >>> mObj m
  "BinTree Direction"
  
  >>> mObjSub m
  "BinTree Direction-binary"
  
  >>> mSub m
  "binary"
  
  >>> allOf mObj ms
  ["BinTree Direction","Cars"]
  
  >>> allOf mType ms
  ["deserialization (time)","serialization (time)","size (bytes)"]
  
  >>> summaryTable ms
  [("BinTree Direction",[("deserialization (time)",[(1989.0,[Measure {mTest = "deserialization (time)/BinTree Direction-binary", mValue = 1989.0}])]),("serialization (time)",[(1004.0,[Measure {mTest = "serialization (time)/BinTree Direction-binary", mValue = 1004.0}])]),("size (bytes)",[(6291455.0,[Measure {mTest = "size (bytes)/BinTree Direction-binary", mValue = 6291455.0}])])]),("Cars",[("size (bytes)",[(300000.0,[Measure {mTest = "size (bytes)/Cars-flat", mValue = 300000.0}]),(301455.0,[Measure {mTest = "size (bytes)/Cars-binary", mValue = 301455.0}])])])]
  
  >>> renderTable ms 
  "|Dataset\\Measure|deserialization|serialization|size|\n| ---| ---| ---| ---|\n|BinTree Direction|[binary](https://hackage.haskell.org/package/binary)|[binary](https://hackage.haskell.org/package/binary)|[binary](https://hackage.haskell.org/package/binary)|\n|Cars|||[flat](https://hackage.haskell.org/package/flat),[binary](https://hackage.haskell.org/package/binary)|\n"
  
  >>> addTransfers_ ms
  fromList [("deserialization (time)/BinTree Direction-binary",Measure {mTest = "deserialization (time)/BinTree Direction-binary", mValue = 1989.0}),("serialization (time)/BinTree Direction-binary",Measure {mTest = "serialization (time)/BinTree Direction-binary", mValue = 1004.0}),("size (bytes)/BinTree Direction-binary",Measure {mTest = "size (bytes)/BinTree Direction-binary", mValue = 6291455.0}),("size (bytes)/Cars-binary",Measure {mTest = "size (bytes)/Cars-binary", mValue = 301455.0}),("size (bytes)/Cars-flat",Measure {mTest = "size (bytes)/Cars-flat", mValue = 300000.0}),("transfer [10 MBits] (time)/BinTree Direction-binary",Measure {mTest = "transfer [10 MBits] (time)/BinTree Direction-binary", mValue = 8026.164}),("transfer [100 MBits] (time)/BinTree Direction-binary",Measure {mTest = "transfer [100 MBits] (time)/BinTree Direction-binary", mValue = 3496.3164}),("transfer [1000 MBits] (time)/BinTree Direction-binary",Measure {mTest = "transfer [1000 MBits] (time)/BinTree Direction-binary", mValue = 3043.33164})]
  -}
  renderTable :: Measures -> String
  renderTable ms =
    let
      tests = allOf mObj ms
      kinds = allOf mType ms
      vals  = allOf mSub ms
      lines s = s : map (\t -> showPkgs $ map (\v -> tos t s v ms) vals) kinds
    in
      unlines
      . map mdRow
      $ ("Dataset\\Measure" : map short kinds)
      : replicate (length kinds + 1) " ---"
      : map lines tests
   where
    pkgVals = map snd . tops . sort . catMaybes . map
      ((\m -> (mValue m, pkgRef $ mSub m)) <$>)
    tops [] = []
    tops hs =
      let limit = fst (head hs) * 1.3 in takeWhile (\e -> fst e <= limit) hs
    showPkgs = intercalate "," . pkgVals
    mdRow vs = concat ["|", intercalate "|" vs, "|"]
    pkgRef name =
      concat ["[", name, "](https://hackage.haskell.org/package/", name, ")"]
    short = unwords . init . words
  
  tos :: String -> String -> String -> Measures -> Maybe Measure
  tos t o s ms = M.lookup (concat [t, "/", o, "-", s]) ms
  
  summaryTable :: M.Map k Measure -> [(String, [(String, [(Double, [Measure])])])]
  summaryTable =
    map (second $ (map (second $ by mValue) . by mType)) . by mObj . M.elems
  
  addTransfers :: FilePath -> IO ()
  addTransfers workDir = addMeasures__ workDir addTransfers_ >> return ()
  
  addTransfers_ :: Measures -> Measures
  addTransfers_ ms =
    let
      tests = allOf mObjSub ms
      addT :: Measures -> String -> Measures
      addT ms o =
        fromMaybe ms
          $   (\ser des siz ->
                let
                  add1 :: Double -> Measures -> Measures
                  add1 megaBits ms =
                    let
                      trans =
                        concat
                          [ "transfer ["
                          , show (round megaBits :: Integer)
                          , " MBits] (time)/"
                          , o
                          ]
                      time =
                        mValue ser + mValue des + mValue siz * 8 / (megaBits * 1000)
                    in
                      add (Measure trans time) ms
                in
                  add1 1000 (add1 100 (add1 10 ms))
              )
          <$> M.lookup ("serialization (time)/" ++ o) ms
          <*> M.lookup ("deserialization (time)/" ++ o) ms
          <*> M.lookup ("size (bytes)/" ++ o) ms
    in
      foldl addT ms tests
  
  add :: Measure -> Measures -> Measures
  add m = M.insert (mTest m) m
  
  mKindPkg :: Measure -> (String, String)
  mKindPkg m = let (k, _ : p) = break (== '-') $ mTest m in (k, p)
  
  mKind :: Measure -> String
  mKind = fst . mKindPkg
  
  mType :: Measure -> String
  mType = brk1 '/' . mKind
  
  mObj :: Measure -> String
  mObj = brk2 '/' . mKind
  
  mObjSub :: Measure -> String
  mObjSub = brk2 '/' . mTest
  
  mSub :: Measure -> String
  mSub = brk2 '-' . mObjSub
  
  brk1 :: Eq a => a -> [a] -> [a]
  brk1 sep = fst . break (== sep)
  
  brk2 :: Eq a => a -> [a] -> [a]
  brk2 sep = tail . snd . break (== sep)
  
  mKindPkgVal :: Measure -> (String, (String, Double))
  mKindPkgVal m = let (k, p) = mKindPkg m in (k, (p, mValue m))
  
  byTestKind :: Measures -> [(String, (String, Double))]
  byTestKind = map mKindPkgVal . M.elems
  
  allKinds :: Measures -> [String]
  allKinds = allOf mKind
  
  allOf :: Eq a1 => (a2 -> a1) -> M.Map k a2 -> [a1]
  allOf f = nub . map f . M.elems
  
  allTests :: [(String, (String, Double))] -> [(String, [(String, Double)])]
  allTests = -- by fst
             sort . map (\g -> (fst . head $ g, map snd g)) . groupBy
    (\a b -> fst a == fst b)
  
  -- order by dimension
  by :: (Ord a, Ord t) => (t -> a) -> [t] -> [(a, [t])]
  by f = sort . map (\g -> (f $ head g, g)) . groupBy (\a b -> f a == f b)
  
  toMeasures :: [Report] -> Measures
  toMeasures = measures . map toMeasure
  
  measures :: [Measure] -> Measures
  measures = M.fromList . map (\m -> (mTest m, m))
  
  toMeasure :: Report -> Measure
  toMeasure r =
    Measure (reportName r) ((1000 *) . estPoint . anMean . reportAnalysis $ r)
  
  deleteMeasures :: FilePath -> IO ()
  deleteMeasures = removeFile . measuresFile
  
  updateMeasures :: FilePath -> IO ()
  updateMeasures = void . updateMeasures_
  
  updateMeasures_ :: FilePath -> IO (Measures, Measures, Measures)
  updateMeasures_ dir = do
    m' <- readCriterionMeasures dir
    addMeasures_ dir m'
  
  addMeasures_ :: FilePath -> Measures -> IO (Measures, Measures, Measures)
  addMeasures_ dir m' = addMeasures__ dir (const m')
  
  addMeasures__
    :: FilePath -> (Measures -> Measures) -> IO (Measures, Measures, Measures)
  addMeasures__ dir f = do
    !m <- readMeasures dir
    let m'  = f m
    let m'' = M.union m' m
    writeMeasures dir m''
    return (m, m', m'')
  
  addMeasures :: FilePath -> String -> [(String, Double)] -> IO ()
  addMeasures dir name ms = void $ addMeasures_
    dir
    (M.fromList $ map
      (\(pkg, val) -> let n = concat [name, "-", pkg] in (n, Measure n val))
      ms
    )
  
  readMeasures :: FilePath -> IO Measures
  readMeasures dir = do
    let f = measuresFile dir
    fe <- doesFileExist f
    if not fe then return M.empty else (force . read) <$> readFile f
  
  writeMeasures :: FilePath -> Measures -> IO ()
  writeMeasures dir = writeFile (measuresFile dir) . show
  
  readCriterionMeasures :: FilePath -> IO Measures
  readCriterionMeasures dir = toMeasures <$> readReports (reportsFile dir)
  
  measuresFile :: FilePath -> FilePath
  measuresFile dir = dir </> "measures"
  
  reportsFile :: FilePath -> FilePath
  reportsFile dir = dir </> "report.json"
  
  reportsMDFile :: FilePath -> FilePath
  reportsMDFile dir = dir </> "report.md"
  
  printMeasures :: FilePath -> IO ()
  printMeasures dir = reportMeasures_ dir >>= putStrLn
  
  printSummary :: FilePath -> (String -> Bool) -> IO ()
  printSummary dir f =
    readMeasures dir >>= putStrLn . renderTable . M.filter (f . mTest)
  
  reportMeasures :: FilePath -> IO ()
  reportMeasures dir =
    reportMeasures_ dir
      >>= writeFile (reportsMDFile dir)
      . ("Results that are within 30% of the best result are displayed in **bold**.\n\n" ++
        )
  
  reportMeasures_ :: FilePath -> IO String
  reportMeasures_ dir = reportMeasures__ (const True) <$> readMeasures dir
  
  printMeasuresCurrent :: (Measures, Measures, Measures) -> IO ()
  printMeasuresCurrent (_, m', m'') =
    let currentKinds = allKinds m'
    in  printMeasuresAll_ (\ts -> fst ts `elem` currentKinds) m''
  
  printMeasuresAll_ :: ((String, [(String, Double)]) -> Bool) -> Measures -> IO ()
  printMeasuresAll_ f = putStrLn . reportMeasures__ f
  
  reportMeasures__ :: ((String, [(String, Double)]) -> Bool) -> Measures -> String
  reportMeasures__ f =
    concatMap (uncurry report) . filter f . allTests . byTestKind
  
  printMeasuresDiff :: (Measures, Measures, Measures) -> IO ()
  printMeasuresDiff (m, m', _) =
    mapM_ (\(n, d) -> putStrLn (unwords [n, show d, "%"]))
      . M.toList
      $ M.intersectionWith
          (\a b -> round ((mValue b / mValue a - 1) * 100) :: Int)
          m
          m'
  
  readReports :: FilePath -> IO [Report]
  readReports jsonReportFile = do
    fe <- doesFileExist jsonReportFile
    if not fe
      then return [] -- M.empty
      else do
        er <- readJSONReports jsonReportFile
        return $ case er of
          Right (_, _, reports) -> reports
          _                     -> [] -- M.empty
  
  report :: String -> [(String, Double)] -> String
  report _ [] = []
  report name rs =
    let (_, rss) = report_ rs
        width    = maximum . map (length . fst) $ rs
        out =
          [ "| ---| ---|"
          , "| package | performance |"
          , ""
          , unwords ["####", name, "(best first)"]
          ]
            -- out = ["| ---| ---| ---|","| package | measure | relative measure |","",unwords ["####",name, "(best first)"]] 
    in  unlines
        . reverse
        $ ""
        : foldl'
            (\out (n, r, a) ->
              let bold n = concat ["**", n, "**"]
                  marked n = -- fix prob with github bold display
                             if r <= 1.3
                    then if isSpace (head n)
                      then let (n1, n2) = span isSpace n in n1 ++ bold n2
                      else
                        let (n1, n2) = span (not . isSpace) n in bold n1 ++ n2
                    else n
              in  unwords
                      [ "|"
                      , marked (printString width n) -- pkg name
                      , "|"
                    -- , printf "%11.1f" a -- absolute measure
                    -- ,"|"
                      , marked (printDouble r) -- relative measure
                      , "|"
                      ]
                    : out
            )
            out
            rss
  
  report_ :: (Fractional c, Ord c) => [(a, c)] -> ((a, c), [(a, c, c)])
  report_ rs =
    let rss  = sortOn snd rs
        best = snd . head $ rss
    in  (head rss, map (\(n, v) -> (n, v / best, v)) rss)
  
  printDouble :: Double -> String
  printDouble = printf "%7.1f"
  
  printInt :: Double -> String
  printInt = printf "%.0f"
  
  printString :: Int -> String -> String
  printString width = printf ("%-" ++ show width ++ "s")
  