content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE RecursiveDo #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE TypeSynonymInstances #-}
  
  module Reflex.Bench.Focused where
  
  import Reflex
  import Reflex.TestPlan
  
  import Control.Applicative
  import Control.Monad
  import Control.Monad.Fix
  import Control.Monad.Identity
  import Data.Traversable (for, traverse)
  
  import qualified Data.Dependent.Map as DMap
  import Data.Map (Map)
  import qualified Data.Map as Map
  import Data.Maybe
  
  import Data.Functor.Misc
  
  import Data.List
  import Data.List.Split
  import Data.Tuple
  
  import Data.Monoid
  import Data.Word
  
  import Control.DeepSeq
  
  import Prelude hiding (concat, sum)
  
  
  mergeTree :: Num a => (Monoid (f [a]), Functor f) => Int -> [f a] -> f a
  mergeTree n es | length es <= n =  sum' es
                 | otherwise = mergeTree n subTrees
    where
      merges   = chunksOf n es
      subTrees = map sum' merges
      sum'     = fmap sum . mconcat . fmap (fmap (:[]) )
  
  mergeListDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]
  mergeListDyn = mconcat . fmap (fmap pure)
  
  mergeTreeDyn :: (Num a, Reflex t) => Int -> [Dynamic t a] -> Dynamic t a
  mergeTreeDyn n dyns | length dyns <= n = sumDyns dyns
                      | otherwise = mergeTreeDyn n $ fmap sumDyns merges
    where
      merges = chunksOf n dyns
      sumDyns = fmap sum . mergeListDyn
  
  
  
  -- N events all firing for N frames
  continuous :: TestPlan t m => Word -> Word -> m [Event t Word]
  continuous n frames = for [1..n] $ \i -> plan $ (, i) <$> [1..frames]
  
  -- Fire N events once every P frames for total N frames (interspersed evenly)
  occasional :: TestPlan t m => Word -> Word -> Word -> m [Event t Word]
  occasional n period frames = traverse plan $ zipWith occs [1..] phases
    where
      phases       = take (fromIntegral n) $ concat (repeat [1..period])
      occs i phase = (, i) <$> [1, phase+1..frames]
  
  
  
  -- Event which never fires (but isn't 'never')
  never' :: TestPlan t m => m (Event t Word)
  never' = plan []
  
  
  -- Event which fires once on first frame
  event :: TestPlan t m => m (Event t Word)
  event = plan [(1, 0)]
  
  -- Event which fires constantly over N frames
  events :: TestPlan t m => Word -> m (Event t Word)
  events n  = plan $ (\i -> (i, i)) <$> [1..n]
  
  
  -- N events all originating from one event
  fmapFan :: Reflex t => Word -> Event t Word -> [Event t Word]
  fmapFan n e = (\i -> (+i) <$> e) <$> [1..n]
  
  
  -- Make a fan using the value in the event converting it to a singleton Map
  -- use a fan of size n (key is the value mod n)
  fanMerge :: Reflex t => Word -> Event t Word -> Event t Word
  fanMerge n e =  leftmost $ s <$> [0..n - 1] where
    s k = select f (Const2 k)
    f = fan (toMap <$> e)
    toMap k = DMap.singleton (Const2 $ k `mod` n) (Identity k)
  
  -- Dumb version of the above using simple fmapMaybe to filter
  fmapFanMerge :: Reflex t => Word -> Event t Word -> Event t Word
  fmapFanMerge n e =  leftmost $ s <$> [0..n - 1] where
    s k = flip fmapMaybe e $ \j -> if k == j `mod` n
      then Just k
      else Nothing
  
  
  
  -- Create an Event with a Map which is dense to size N
  denseMap :: TestPlan t m => Word -> m (Event t (Map Word Word))
  denseMap n = plan [(1, m)] where
    m = Map.fromList $ zip [1..n] [1..n]
  
  iter :: (a -> a) -> Word -> a -> a
  iter _ 0 a = a
  iter f n a = iter f (n - 1) (f a)
  
  iterM :: Monad m => (a -> m a) -> Word -> a -> m a
  iterM _ 0 a = return a
  iterM f n a = iterM f (n - 1) =<< f a
  
  fmapChain :: (Functor f) => Word -> f Word -> f Word
  fmapChain = iter (fmap (+1))
  
  mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
  mapDynChain = iterM (return . fmap (+1))
  
  joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
  joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
  
  holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
  holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))
  
  buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
  buildDynChain = iterM (\d -> do
      let b = fmap (+1) (current d)
          e = fmap (*2) (updated d)
      buildDynamic (sample b) e)
  
  
  combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
  combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
  
  pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a)
  pingPong e1 e2 = do
    rec
      d <- foldDyn (const swap) (e1, e2) e
      let e = switch (fst <$> current d)
    return e
  
  switchFactors :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
  switchFactors 0 e = return e
  switchFactors i e = do
      b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e)
      switchFactors (i - 1) (switch b)
  
  
  switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
  switchChain  = iterM (\e -> pingPong e ((+1) <$> e))
  
  
  switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
  switchChain2 = iterM (\e -> pingPong e ((+1) <$> leftmost [e, e]))
  
  switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
  switchPromptlyChain = iterM $ \e ->
      switchPromptlyDyn <$> holdDyn e (e <$ e)
  
  
  coinChain :: Reflex t => Word -> Event t Word -> Event t Word
  coinChain = iter $ \e -> coincidence (e <$ e)
  
  fanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
  fanMergeChain width = iter $ fanMerge width
  
  fmapFanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
  fmapFanMergeChain width = iter $ fmapFanMerge width
  
  -- | Data type for a collection (a map) which is updated by providing differences
  data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))
  
  -- This will hopefully become a primitive (faster!)
  switchMergeEvents ::  (MonadFix m, MonadHold t m, Reflex t, Ord k) =>  UpdatedMap t k (Event t a)  -> m (Event t (Map k a))
  switchMergeEvents mapChanges = switch . fmap mergeMap  <$> holdMap mapChanges
  
  -- switchMergeMaybe :: (MonadFix m, MonadHold t m, Reflex t, Ord k) =>  UpdatedMap t k (Event t a)  -> m (Event t (Map k a))
  -- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes)
  
  switchMergeBehaviors  :: forall a t m k. (MonadFix m, MonadHold t m, Reflex t, Ord k) =>  UpdatedMap t k (Behavior t a)  -> m (Behavior t (Map k a))
  switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges
    where joinMap m = traverse sample =<< sample m
  
  -- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value
  holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))
  holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldrWithKey modify)) initial changes
  
    where
      modify k Nothing items = Map.delete k items
      modify k (Just item) items = Map.insert k item items
  
  
  -- | Hold an UpdatedMap as a behavior by applying differences to the initial value
  holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))
  holdMap = (current <$>) . holdMapDyn
  
  
  increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)
  increasingMerge xs = do
    e   <- planList (zipWith Map.singleton  [1..] (Just <$> xs) ++ [reset])
    return (UpdatedMap Map.empty e)
      where
        reset = Map.fromList $ zip [1..] (const Nothing <$> xs)
  
  decreasingMerge ::  (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
  decreasingMerge xs = do
    e <- planList (zipWith Map.singleton  [1..] (const Nothing <$> xs) ++ [reset])
    return (UpdatedMap initial e)
      where
        initial = Map.fromList $ zip [1..] xs
        reset = Just <$> initial
  
  modifyMerge :: (TestPlan t m) =>  [a] -> m (UpdatedMap t Int a)
  modifyMerge xs = do
    e <- planList $ zipWith Map.singleton  [1..] (Just <$> xs)
    return (UpdatedMap initial e)
      where
        initial = Map.fromList $ zip [1..] xs
  
  
  countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]
  countMany = traverse (fmap current . count)
  
  countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]
  countManyDyn = traverse count
  
  
  -- Given a function which creates a sub-network (from a single event)
  -- Create a plan which uses a switch to substitute it
  switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)
  switches numFrames f = do
    es <- events numFrames
    switch <$> hold never (makeEvents es)
  
      where
        makeEvents es =  pushAlways (\n -> f (fmap (+n) es)) es
  
  
  
  -- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)
  -- the other, which we're only interested in time for running frames
  subscribing :: Word -> Word -> [(String, TestCase)]
  subscribing n frames =
    [ testSub "fmapFanMerge"        $ return . mergeList . fmapFan n
    , testSub "fanMerge"            $ return . fanMerge n
    , testSub "fmapFan/mergeTree"   $ return . mergeTree 8 . fmapFan n
    , testSub "fmapChain"           $ return . fmapChain n
    , testSub "switchChain"         $ switchChain n
    , testSub "switchPromptlyChain" $ switchPromptlyChain n
    , testSub "switchFactors"       $ switchFactors n
    , testSub "coincidenceChain"    $ return . coinChain n
    ]
  
    where
      testSub :: (Eq a, Show a, NFData a) => String -> (forall t n. (Reflex t, MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> (String, TestCase)
      testSub name test = testE name (switches frames test)
  
  -- Set of benchmark to test specifically merging dynamic collections
  -- a pattern which occurs frequently in reflex-dom collections
  merging :: Word -> [(String, TestCase)]
  merging n =
    [ testE "static events"        $ mergeList <$> sparse
    , testE "increasing events"    $ switchMergeEvents =<< increasingMerge =<< sparse
    , testE "decreasing events"    $ switchMergeEvents =<< decreasingMerge =<< sparse
    , testE "modify events"        $ switchMergeEvents =<< modifyMerge =<< sparse
  
    , testB "static behaviors"     $ pull . traverse sample <$> counters
    , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters
    , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters
    , testB "modify behaviors"     $ switchMergeBehaviors =<< modifyMerge =<< counters
  
  
    -- , testE "increasing events/switchMerge"    $ switchMergeMaybe =<< increasingMerge =<< sparse
    -- , testE "decreasing events/switchMerge"    $ switchMergeMaybe =<< decreasingMerge =<< sparse
    -- , testE "modify events/switchMerge"        $ switchMergeMaybe =<< modifyMerge =<< sparse
    ]
  
    where
      sparse :: TestPlan t m => m [Event t Word]
      sparse = fmap (fmap (+1)) <$> occasional n 8 n
  
      counters :: TestPlan t m => m [Behavior t Int]
      counters = countMany =<< sparse
  
  
  
  fans :: Word -> [(String, TestCase)]
  fans n =
    [  testE "fanMapChain"               $ fanMergeChain n 10 <$> e
    ,  testE "fmapFanMapChain"           $ fmapFanMergeChain n 10 <$> e
  
    , testE "fanMerge " $ fanMerge n <$> events n
  
    , testE "fmapFanMerge " $ fmapFanMerge n <$> events n
    , testE "triggerMerge" $ leftmost <$> for [1..n] (\i -> plan [(i, i)])
  
    ]
    where
  
      e :: TestPlan t m => m (Event t Word)
      e = events 100
  
  
  
  
  dynamics :: Word -> [(String, TestCase)]
  dynamics n =
    [ testE "mapDynChain"         $ fmap updated $ mapDynChain n =<< d
    , testE "joinDynChain"        $ fmap updated $ joinDynChain n =<< d
    , testE "holdDynChain"        $ fmap updated $ holdDynChain n =<< d
    , testE "buildDynChain"        $ fmap updated $ buildDynChain n =<< d
    , testE "combineDynChain"     $ fmap updated $ combineDynChain n =<< d
    , testE "dense mergeTree"     $ fmap (updated . mergeTreeDyn 8) dense
    , testE "sparse mergeTree"    $ fmap (updated . mergeTreeDyn 8) sparse
    , testE "mergeDyn"            $ fmap (updated . fmap sum . mergeListDyn) sparse
    ] where
  
      d :: TestPlan t m => m (Dynamic t Word)
      d = count =<< events 10
  
      sparse, dense :: TestPlan t m => m [Dynamic t Int]
      sparse = countManyDyn =<< occasional n 8 16
      dense  = countManyDyn =<< continuous n 2
  
  
  firing :: Word -> [(String, TestCase)]
  firing n =
    [ testE "fmapChain"           $ fmapChain n <$> e
    , testE "switchChain2"        $ switchChain2 n =<< e
    , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e
    , testE "switchFactors"       $  switchFactors n =<< e
    , testE "coincidenceChain"    $ coinChain n <$> e
  
    , testE "dense mergeTree"      $ mergeTree 8 <$> dense
    , testE "sparse mergeTree"  $ mergeTree 8 <$> sparse
  
    -- Triggers test failure in Spider
    --, testE "runFrame"               $ events n
  
    , testB "sum counters" $ do
        counts <- counters
        return $ pull $ sum <$> traverse sample counts
  
    , testB "pullChain"                 $ fmapChain n . current <$> (count =<< events 4)
    , testB "pullChain2"                $ do
      es <- events 4
      e' <- plan [(0, ())]
  
      b <- hold (constant 0) $
        pushAlways (const $ fmapChain n <$> hold 0 es) e'
  
      return (join b)
    , testB "counters/pullTree" $ mergeTree 8 <$> counters
  
    ]
      where
        e :: TestPlan t m => m (Event t Word)
        e = events 10
  
        dense, sparse :: TestPlan t m => m [Event t Word]
        dense = continuous n 2
        sparse = occasional n 8 16
  
        counters :: TestPlan t m => m [Behavior t Int]
        counters = countMany =<< sparse
  
  
  
  
  
  