Collection.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
#ifdef USE_REFLEX_OPTIMIZER
{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
#endif
-- |
-- Module:
--   Reflex.Collection
module Reflex.Collection
  (
  -- * Widgets on Collections
    listHoldWithKey
  , listWithKey
  , listWithKeyShallowDiff
  , listViewWithKey
  , selectViewListWithKey
  , selectViewListWithKey_
  -- * List Utils
  , list
  , simpleList
  ) where

#ifdef MIN_VERSION_semialign
import Prelude hiding (zip, zipWith)
#if MIN_VERSION_semialign(1,1,0)
import Data.Zip (Zip (..))
#endif
#endif

import Control.Monad.Identity
import Data.Align
import Data.Functor.Misc
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Map.Misc
import Data.These

import Reflex.Class
import Reflex.Adjustable.Class
import Reflex.Dynamic
import Reflex.PostBuild.Class

-- | Create a set of widgets based on the provided 'Map'. When the
-- input 'Event' fires, remove widgets for keys with the value 'Nothing'
-- and add/replace widgets for keys with 'Just' values.
listHoldWithKey
  :: forall t m k v a
   . (Ord k, Adjustable t m, MonadHold t m)
  => Map k v
  -> Event t (Map k (Maybe v))
  -> (k -> v -> m a)
  -> m (Dynamic t (Map k a))
listHoldWithKey m0 m' f = do
  let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
      dm' = fmap
        (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey
          (\k v -> ComposeMaybe $ fmap (f k) v)
        )
        m'
  (a0, a') <- sequenceDMapWithAdjust dm0 dm'

  --TODO: Move the dmapToMap to the righthand side so it doesn't get
  --fully redone every time
  fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'

--TODO: Something better than Dynamic t (Map k v) - we want something
--where the Events carry diffs, not the whole value
listWithKey
  :: forall t k v m a
   . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m, Eq v)
  => Dynamic t (Map k v)
  -> (k -> Dynamic t v -> m a)
  -> m (Dynamic t (Map k a))
listWithKey vals mkChild = do
  postBuild <- getPostBuild
  let childValChangedSelector = fanMap $ updated vals

      -- We keep track of changes to children values in the mkChild
      -- function we pass to listHoldWithKey The other changes we need
      -- to keep track of are child insertions and
      -- deletions. diffOnlyKeyChanges keeps track of insertions and
      -- deletions but ignores value changes, since they're already
      -- accounted for.
      diffOnlyKeyChanges olds news =
        flip Map.mapMaybe (align olds news) $ \case
          This _    -> Just Nothing
          These _ _ -> Nothing
          That new  -> Just $ Just new
  rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
      let changeVals :: Event t (Map k (Maybe v))
          changeVals =
            attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
              [ updated vals

              -- TODO: This should probably be added to the
              -- attachWith, not to the updated; if we were using
              -- diffMap instead of diffMapNoEq, I think it might not
              -- work
              , tag (current vals) postBuild
              ]
  listHoldWithKey Map.empty changeVals $ \k v ->
    mkChild k =<< holdUniqDyn =<< holdDyn v (select childValChangedSelector $ Const2 k)

-- | Display the given map of items (in key order) using the builder
-- function provided, and update it with the given event.  'Nothing'
-- update entries will delete the corresponding children, and 'Just'
-- entries will create them if they do not exist or send an update
-- event to them if they do.
listWithKeyShallowDiff
  :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m)
  => Map k v
  -> Event t (Map k (Maybe v))
  -> (k -> v -> Event t v -> m a)
  -> m (Dynamic t (Map k a))
listWithKeyShallowDiff initialVals valsChanged mkChild = do
  let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
  sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged
  let relevantPatch patch _ = case patch of

        -- Even if we let a Nothing through when the element doesn't
        -- already exist, this doesn't cause a problem because it is
        -- ignored
        Nothing -> Just Nothing

        -- We don't want to let spurious re-creations of items through
        Just _  -> Nothing
  listHoldWithKey
      initialVals
      (attachWith (flip (Map.differenceWith relevantPatch))
                  (current sentVals)
                  valsChanged
      )
    $ \k v -> mkChild k v $ select childValChangedSelector $ Const2 k

--TODO: Something better than Dynamic t (Map k v) - we want something
--where the Events carry diffs, not the whole value
-- | Create a dynamically-changing set of Event-valued widgets.  This
--   is like 'listWithKey', specialized for widgets returning @/Event t a/@.
--   'listWithKey' would return @/Dynamic t (Map k (Event t a))/@ in
--   this scenario, but 'listViewWithKey' flattens this to
--   @/Event t (Map k a)/@ via 'switch'.
listViewWithKey
  :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m, Eq v)
  => Dynamic t (Map k v)
  -> (k -> Dynamic t v -> m (Event t a))
  -> m (Event t (Map k a))
listViewWithKey vals mkChild =
  switch . fmap mergeMap <$> listViewWithKey' vals mkChild

listViewWithKey'
  :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m, Eq v)
  => Dynamic t (Map k v)
  -> (k -> Dynamic t v -> m a)
  -> m (Behavior t (Map k a))
listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild

-- | Create a dynamically-changing set of widgets, one of which is
-- selected at any time.
selectViewListWithKey
  :: forall t m k v a
   . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m, Eq v)
  => Dynamic t k
  -- ^ Current selection key
  -> Dynamic t (Map k v)
  -- ^ Dynamic key/value map
  -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))
  -- ^ Function to create a widget for a given key from Dynamic value
  -- and Dynamic Bool indicating if this widget is currently selected
  -> m (Event t (k, a))
  -- ^ Event that fires when any child's return Event fires.  Contains
  -- key of an arbitrary firing widget.
selectViewListWithKey selection vals mkChild = do
  -- For good performance, this value must be shared across all children
  let selectionDemux = demux selection
  selectChild <- listWithKey vals $ \k v -> do
    let selected = demuxed selectionDemux k
    selectSelf <- mkChild k v selected
    return $ fmap ((,) k) selectSelf
  return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild

-- | Like 'selectViewListWithKey' but discards the value of the list
-- item widget's output 'Event'.
selectViewListWithKey_
  :: forall t m k v a
   . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m, Eq v)
  => Dynamic t k
  -- ^ Current selection key
  -> Dynamic t (Map k v)
  -- ^ Dynamic key/value map
  -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))
  -- ^ Function to create a widget for a given key from Dynamic value
  -- and Dynamic Bool indicating if this widget is currently selected
  -> m (Event t k)
  -- ^ Event that fires when any child's return Event fires.  Contains
  -- key of an arbitrary firing widget.
selectViewListWithKey_ selection vals mkChild =
  fmap fst <$> selectViewListWithKey selection vals mkChild

-- | Create a dynamically-changing set of widgets from a Dynamic
--   key/value map.  Unlike the 'withKey' variants, the child widgets
--   are insensitive to which key they're associated with.
list
  :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m, Eq v)
  => Dynamic t (Map k v)
  -> (Dynamic t v -> m a)
  -> m (Dynamic t (Map k a))
list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)

-- | Create a dynamically-changing set of widgets from a Dynamic list.
simpleList
  :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m, Eq v)
  => Dynamic t [v]
  -> (Dynamic t v -> m a)
  -> m (Dynamic t [a])
simpleList xs mkChild =
  fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap
    (Map.fromList . zip [(1 :: Int) ..])
    xs