{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE RankNTypes #-}
module Table where

import Control.Monad (ap)
import Data.Foldable (for_)
import Data.Map      (Map)
import Numeric       (showFFloat)

import qualified Text.PrettyPrint.Boxes as B
import qualified Data.Map.Strict as Map

import Types

-- | Row of things.
--
-- Name, first column, and then pair of columns
data Row f a = Row a a [f a]
  deriving (Show, Functor, Foldable)

hoistRow :: (f a -> g a) -> Row f a -> Row g a
hoistRow f (Row x y zs) = Row x y (map f zs)

instance Applicative f => Applicative (Row f) where
    pure x = Row x x (repeat (pure x))

    Row f1 f2 fs <*> Row x1 x2 xs =
        Row (f1 x1) (f2 x2) (zipWith (<*>) fs xs)

newtype V1 a = V1 a
  deriving (Show, Functor, Foldable)

instance Applicative V1 where
    pure x = V1 x
    V1 f1 <*> V1 x1 = V1 (f1 x1)

data V2 a = V2 a a
  deriving (Show, Functor, Foldable)

instance Applicative V2 where
    pure x = V2 x x
    V2 f1 f2 <*> V2 x1 x2 = V2 (f1 x1) (f2 x2)

makeHeader
    :: RunName    -- ^ first run
    -> [RunName]  -- ^ other runs
    -> Row V1 B.Box
makeHeader fname names =
    fmap B.text $ Row "Benchmark"  (getRunName fname) (map (V1 . getRunName) names)

makeTable
    :: RunName    -- ^ first run
    -> [RunName]  -- ^ other runs
    -> Map RowName (Map RunName Stats)
    -> [Row V2 B.Box]
makeTable fname names results = map (fmap B.text) $ buildList $ do
    -- rows
    for_ (Map.toList results) $ \(rn, mp) ->
        for_ (Map.lookup fname mp) $ \fstats ->  do
            let fmean :: Double
                fmean = statsMean fstats

                precision :: Int
                precision = round $ logBase 10 fmean

                -- rest benchmarks
                rest :: [V2 String]
                rest = buildList $ do
                    for_ names $ \name -> case Map.lookup name mp of
                        Nothing    -> do
                            item (V2 "" "")
                        Just stats -> do
                            let mean = statsMean stats
                            item $ V2 (showD precision mean) (showP fmean mean)

            -- name, first, rest
            item $ Row (getRowName rn) (showD precision fmean) rest
  where
    showD :: Int -> Double -> String
    showD p d = showFFloat (Just 3) (mul * d) . showChar 'e' . shows p $ ""
      where mul = 10 ^ negate p

    showP :: Double -> Double -> String
    showP orig curr
        | curr > orig  = '+' : showFFloat (Just 2) (100 * (curr - orig) / orig) "%"
        | otherwise    = '-' : showFFloat (Just 2) (100 * (orig - curr) / orig) "%"

-------------------------------------------------------------------------------
-- List Builder
-------------------------------------------------------------------------------

newtype ListBuilder x a = LB { unLB :: forall r. (([x] -> [x]) -> a -> r) -> r }

instance Functor (ListBuilder x) where
    fmap f (LB k) = LB $ k $ \endo a k' -> k' endo (f a)

instance Applicative (ListBuilder x) where
    pure x = LB $ \f -> f id x
    (<*>)  = ap

instance Monad (ListBuilder x) where
    return = pure

    m >>= k =
        LB $ \r ->
        unLB m $ \endo1 a ->
        unLB (k a) $ \endo2 b ->
        r (endo1 . endo2) b

buildList :: ListBuilder x () -> [x]
buildList (LB f) = f $ \endo _ -> endo []

item :: x -> ListBuilder x ()
item x = LB $ \f -> f (x :) ()