{-# LANGUAGE UndecidableInstances #-}

module Reflex.Switching 
  ( Switching (..)
  , SwitchMerge (..)
  , switching'
  , switchMerge'
  
  ) where


import Reflex.Class hiding (constant)
import Reflex.Updated

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

import Control.Monad
import Control.Monad.Fix
import Control.Applicative
import Data.Semigroup
import Data.Maybe
import Data.Foldable

import Prelude hiding (foldl1)


class (Reflex t) => Switching t r  where
   -- | Generalization of switchable reactive types (e.g. Event, Behavior)
   switching :: MonadHold t m => r -> Event t r -> m r
   
class (Switching t r, Monoid r) => SwitchMerge t r  where   
   -- | Switching for a changing collections of reactive types
   switchMerge :: (MonadFix m, MonadHold t m, Ord k) => Map k r -> Event t (Map k (Maybe r)) -> m r


instance (Switching t a, Switching t b) => Switching t (a, b) where
  switching (a, b) e = liftA2 (,) (switching a $ fst <$> e) (switching b $ snd <$> e)
  
  
instance (SwitchMerge t a, SwitchMerge t b) => SwitchMerge t (a, b) where
  switchMerge initial e = liftA2 (,) (switchMerge' a) (switchMerge' b)
      where (a, b) = split $ UpdatedMap initial e

      

  

-- 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 


instance (Semigroup a, Reflex t) => SwitchMerge t (Event t a) where
  switchMerge initial updates = fmap (foldl1 (<>)) <$> switchMergeEvents (UpdatedMap initial updates)
  
  
instance (Monoid a, Reflex t) => SwitchMerge t (Behavior t a) where
  switchMerge initial updates = pull <$> joinMap <$> holdMap (UpdatedMap initial updates)
    where joinMap m = sample =<< fold <$> sample m
  

mayConcat :: Monoid a => [a] -> Maybe a
mayConcat [] = Nothing
mayConcat xs = Just $ mconcat xs

-- We can optimise [a] a little by eliminating any empty lists before merging
instance (SwitchMerge t a, Monoid a, Reflex t) => SwitchMerge t [a] where
  switchMerge initial updates = pure <$> switchMerge initial' updates'
    where 
      initial' = Map.mapMaybe mayConcat initial
      updates' = fmap (join . fmap mayConcat) <$> updates

  
instance (Switching t a, Monoid a, Reflex t) => Switching t [a]  where
  switching bs updates = pure <$> switching (mconcat bs) (mconcat <$> updates)  
  
  
instance (Reflex t) => SwitchMerge t () where
  switchMerge _ _ = pure ()  


instance (Monoid a, Reflex t) => Switching t (Behavior t a)  where
  switching = switcher
    
instance (Semigroup a, Reflex t) => Switching t (Event t a) where
  switching e updates = switch <$> hold e updates
    
instance (Reflex t) => Switching t () where
  switching _ _ = pure ()
  
  
-- | Helper which takes an UpdatedMap as one argument (instead of initial value, update event separately)
switchMerge' :: (Reflex t, SwitchMerge t r, MonadFix m, MonadHold t m, Ord k) => UpdatedMap t k r -> m r 
switchMerge' (UpdatedMap initial e) = switchMerge initial e  


-- | Helper which takes an Updated as one argument (instead of initial value, update event separately)
switching' :: (Reflex t, Switching t r, MonadFix m, MonadHold t m) => Updated t r -> m r 
switching' (Updated initial e) = switching initial e