Dynamic list with upsort

dynlistUpsort.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE RecursiveDo      #-}

module Reflex.Dom.Contrib.Widgets.DynamicListWithUpsort where

import qualified Data.Map as M
import qualified Data.List as L
import           Data.Monoid
import           Reflex
import           Reflex.Dom.Core


dynamicListWithUpSort
    :: MonadWidget t m
    => (Int -> a -> Event t a -> m b)
    -- ^ Widget used to display each item
    -> (b -> Dynamic t a)
    -- ^ Access of current value
    -> (b -> Event t ())
    -- ^ upSort trigger
    -> (b -> Event t ())
    -- ^ Function that gets a remove event from the return value of each item
    -> (b -> Event t a)
    -- ^ Event that adds a new item to the list that is somehow based on an
    -- existing item.  If you don't want anything like this, use `const never`.
    -> Event t a
    -- ^ Event that adds a new item to the list that is not based on an
    -- existing item.
    -> [a]
    -- ^ Initial list of items
    -> m (Dynamic t [b])
dynamicListWithUpSort w extractVal removeEvent upEvt addFunc addEvent initList = do
    let initMap = M.fromList $ zip [0..] initList
    rec let vals = mergeWith (<>)
              [ attachWith addNew (current res) addEvent
              , addSpecific (current res)
              , remove (current res)
              , up (current res)
              ]
        res <- listWithKeyShallowDiff initMap vals w
    return $ M.elems <$> res
  where
    addSpecific res = switch (foo <$> res)
    foo m = leftmost $ map (fmap (addNew m) . addFunc) $ M.elems m
    addNew m a = M.singleton k (Just a)
      where
        k = if M.null m then 0 else fst (M.findMax m) + 1
    remove res = switch (mergeWith (<>) . map f . M.toList <$> res)
      where
        f (k,b) = M.singleton k Nothing <$ removeEvent b

    up res = switch (mergeWith (<>) . switchPair . L.sortOn fst . M.toList <$> res)
      where
        switchPair [] = []
        switchPair [x] = []
        switchPair ((k1,v1):(k2,v2):xs) =
          let upEvt' = upEvt v2
              val1 = (M.singleton k1 . Just) <$> tagPromptlyDyn (extractVal v2) upEvt'
              val2 = (M.singleton k2 . Just) <$> tagPromptlyDyn (extractVal v1) upEvt'
          in [val1, val2] ++ switchPair ((k2,v2):xs)