fix: correctly implement moving tabs when more than one groups

src/Model/GlobalState.purs

@@ -11,6 +11,7 @@ module PureTabs.Model.GlobalState (
   , _tabFromTabIdAndWindow
   , _tabFromWindow
   , _tabId
+  , _tabIndex
   , _tabs
   , _tabWindowId
   , _windowIdToWindow
@@ -40,7 +41,7 @@ import Control.Alt ((<|>))
 import Control.Bind (join, bind, (>>=))
 import Control.Category (identity, (<<<), (>>>))
 import Control.Plus (empty) as A
-import Data.Array (sortBy, singleton, fromFoldable, insertAt, deleteAt, mapWithIndex, foldl, filter, (!!)) as A
+import Data.Array (deleteAt, filter, foldl, fromFoldable, insertAt, mapWithIndex, sortBy, (!!)) as A
 import Data.Eq ((==), (/=))
 import Data.Function (const, on, ($))
 import Data.Functor (map, (<#>), (<$>))
@@ -100,21 +101,24 @@ _windows = prop (SProxy :: _ "windows")
 _title :: forall a r. Lens' { title :: a | r } a
 _title = prop (SProxy :: _ "title")
 
+_tabTitle :: Lens' Tab String
+_tabTitle = _Newtype <<< _title
+
 _index :: forall a r. Lens' { index :: a | r } a
 _index = prop (SProxy :: _ "index")
 
-_tabTitle :: Lens' Tab String
-_tabTitle = _Newtype <<< _title
+_tabIndex :: Lens' Tab Int
+_tabIndex = _Newtype <<< _index
 
 _id :: forall a r. Lens' { id :: a | r } a
 _id = prop (SProxy :: _ "id")
 
-_active :: forall a r. Lens' { active :: a | r } a
-_active = prop (SProxy :: _ "active")
-
 _tabId :: Lens' Tab TabId
 _tabId = _Newtype <<< _id
 
+_active :: forall a r. Lens' { active :: a | r } a
+_active = prop (SProxy :: _ "active")
+
 _windowId :: forall a r. Lens' { windowId :: a | r } a
 _windowId = prop (SProxy :: _ "windowId")
 

src/Sidebar/Components/Bar.purs

@@ -2,30 +2,31 @@ module PureTabs.Sidebar.Bar where
 
 import Browser.Tabs (Tab(..), TabId)
 import Control.Alternative (pure)
-import Control.Bind (bind, discard, void, (<#>))
+import Control.Bind (bind, discard, map, void, (*>), (<#>))
 import Data.Array ((:))
+import Data.Array as A
 import Data.Function (($))
-import Data.Lens (view)
 import Data.Map as M
-import Data.Maybe (Maybe(..))
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
 import Data.Set (toUnfoldable, Set) as S
 import Data.Set.NonEmpty (cons, max) as NES
 import Data.Symbol (SProxy(..))
 import Data.Tuple (Tuple(..))
+import Data.Tuple as T
 import Data.Unit (Unit, unit)
 import Effect.Aff.Class (class MonadAff)
 import Effect.Class (class MonadEffect)
+import Effect.Console (log)
 import Halogen as H
 import Halogen.HTML as HH
 import Halogen.HTML.Events as HE
 import Halogen.HTML.Properties as HP
-import Prelude (class Eq, class Ord, class Show, show, (+), (<<<), (<>), (==))
-import PureTabs.Model.Events (SidebarEvent)
-import PureTabs.Model.GlobalState (_tabId)
+import Prelude (class Eq, class Ord, class Show, flip, show, (#), (&&), (+), (-), (<<<), (<>), (==), (>>>))
+import PureTabs.Model.Events (SidebarEvent(..))
 import PureTabs.Sidebar.Tabs (Output(..))
 import PureTabs.Sidebar.Tabs as Tabs
 import Sidebar.Component.GroupName as GroupName
-import Sidebar.Utils (whenC)
+import Sidebar.Utils (moveElem, whenC)
 
 newtype GroupId
   = GroupId Int
@@ -44,6 +45,7 @@ type Group
 type State
   = { groups :: M.Map GroupId Group
     , tabsToGroup :: M.Map TabId GroupId
+    , groupTabsPositions :: Array (Tuple TabId GroupId)
     , currentGroup :: GroupId
     }
 
@@ -62,6 +64,7 @@ initialState _ =
     { 
       groups: M.fromFoldable [ Tuple firstGroupId { name: "main", pos: 0 } ]
       , tabsToGroup: M.empty
+      , groupTabsPositions : []
       , currentGroup: firstGroupId 
     }
 
@@ -122,13 +125,44 @@ component =
   handleAction :: Action -> H.HalogenM State Action Slots SidebarEvent m Unit
   handleAction = 
     case _ of
+
          UserSelectedGroup gid -> H.modify_ _ { currentGroup = gid }
+
          UserRenameGroup gid newName -> 
             H.modify_ \s -> s { groups = M.update (\g -> Just $ g { name = newName }) gid s.groups }
+
          UserCreatedGroup -> do
            H.modify_ \s -> s { groups = M.insert (findNextGroupId $ M.keys s.groups) { name: "new group", pos: M.size s.groups } s.groups }
+
          UserDeletedGroup gid -> pure unit
-         HandleTabsOutput gid (TabsSidebarAction sbEvent) -> H.raise sbEvent
+
+         HandleTabsOutput gid (TabsSidebarAction sbEvent) -> 
+           case sbEvent of 
+                -- Important: we ask Firefox to do the move, but we don't
+                -- perform it ourselves.  This means we don't update the state.
+                -- We will get back a TabMoved event that will then be
+                -- processed accordingly.
+                SbMoveTab tid groupIndex -> do
+                   s <- H.get
+                   let 
+                       oldPosition = getPositionTab tid gid s.groupTabsPositions
+                       newIndex = do 
+                         prevIdx <- oldPosition
+                         s.groupTabsPositions #
+                           A.mapWithIndex (Tuple) 
+                                  >>> A.filter (\(Tuple _ (Tuple _ gid')) -> gid' == gid)
+                                  >>> (flip A.index) groupIndex
+                                  >>> map T.fst
+
+                   maybe (pure unit) (\idx -> 
+                     H.raise (SbMoveTab tid idx) 
+                     *> (H.liftEffect $ 
+                       log $ "sb: asking to move tab id " <> (show tid) 
+                         <> " from " <> (show oldPosition) <> " to pos " <> (show idx) 
+                         <> " (group index: " <> (show groupIndex) <> ", gid: " <> (show gid) <> ")"
+                   )) newIndex
+
+                _ -> H.raise sbEvent
 
     where
           findNextGroupId :: S.Set GroupId -> GroupId
@@ -136,46 +170,79 @@ component =
             let GroupId(maxValue) = NES.max (NES.cons (GroupId 0) values)
              in GroupId(maxValue + 1)
 
-  -- TODO: don't use the current group, but use the group associated with the TabId
   handleQuery :: forall act o a. Tabs.Query a -> H.HalogenM State act Slots o m (Maybe a)
   handleQuery = case _ of
 
     Tabs.InitialTabList tabs a -> do
        s <- H.modify (\s -> 
-         s { tabsToGroup = M.fromFoldable $ tabs <#> \(Tab t) -> Tuple t.id s.currentGroup }
+         let 
+             tabIdGroup = tabs <#> \(Tab t) -> Tuple t.id s.currentGroup
+          in
+         s 
+         { tabsToGroup = M.fromFoldable tabIdGroup
+         , groupTabsPositions = tabIdGroup
+         }
        )
        void $ tellChild s.currentGroup $ Tabs.InitialTabList tabs
        pure (Just a)
 
-    Tabs.TabCreated tab a -> do 
-       let tabId = view _tabId tab
-       s <- H.modify (\s -> s { tabsToGroup = M.insert tabId s.currentGroup  s.tabsToGroup })
-       doOnTabGroup tabId \_ -> do
-         void $ tellChild s.currentGroup $ Tabs.TabCreated tab
+    Tabs.TabCreated (Tab tab) a -> do 
+       s <- H.get
+
+       let newGroupTabsPositions = 
+             fromMaybe s.groupTabsPositions 
+             $ A.insertAt tab.index (Tuple tab.id s.currentGroup) s.groupTabsPositions
+
+           inGroupPosition = getPositionTabInGroup tab.index s.currentGroup newGroupTabsPositions 
+
+           newTab = Tab $ tab { index = inGroupPosition }
+
+       newS <- H.modify \state -> 
+         state 
+         { tabsToGroup = M.insert tab.id s.currentGroup s.tabsToGroup 
+         , groupTabsPositions = newGroupTabsPositions
+         }
+
+       void $ tellChild newS.currentGroup $ Tabs.TabCreated newTab
        pure (Just a)
 
     Tabs.TabDeleted tid a -> do 
-       doOnTabGroup tid \_ -> do 
-         s <- H.modify (\s -> s { tabsToGroup = M.delete tid s.tabsToGroup })
-         void $ tellChild s.currentGroup $ Tabs.TabDeleted tid
+       doOnTabGroup tid \gid -> do 
+         H.modify_ (\s -> s 
+                       { tabsToGroup = M.delete tid s.tabsToGroup 
+                       , groupTabsPositions = A.deleteBy 
+                          -- This is ugly. There is no function to delete the
+                          -- first element of an array that matches a condition.
+                          (\(Tuple tid1 _) (Tuple tid2 _) -> tid1 == tid2)
+                          (Tuple tid s.currentGroup)
+                          s.groupTabsPositions
+                       })
+         void $ tellChild gid $ Tabs.TabDeleted tid
        pure (Just a)
 
     Tabs.TabActivated oldTid tid a -> do 
        doOnTabGroup tid \gid -> do 
-         s <- H.modify (_ { currentGroup = gid})
-         void $ tellChild s.currentGroup $ Tabs.TabActivated oldTid tid
+         H.modify_ (_ { currentGroup = gid})
+         void $ tellChild gid $ Tabs.TabActivated oldTid tid
        pure (Just a)
 
-    Tabs.TabMoved tid prev next a -> do 
-       doOnTabGroup tid \_ -> do 
-         s <- H.get
-         void $ tellChild s.currentGroup $ Tabs.TabMoved tid prev next
+    Tabs.TabMoved tid next a -> do 
+       doOnTabGroup tid \gid -> do 
+         { groupTabsPositions } <- H.get 
+         let 
+             newGroupTabsPositions = fromMaybe groupTabsPositions $ do 
+               prevPosition <- getPositionTab tid gid groupTabsPositions
+               moveElem prevPosition next groupTabsPositions
+
+             nextGroupPosition = getPositionTabInGroup next gid newGroupTabsPositions
+
+         H.modify_ (_ { groupTabsPositions = newGroupTabsPositions })
+         void $ tellChild gid $ Tabs.TabMoved tid nextGroupPosition
        pure (Just a)
 
     Tabs.TabInfoChanged tid cinfo a -> do 
-       doOnTabGroup tid \_ -> do
-         s <- H.get
-         void $ tellChild s.currentGroup $ Tabs.TabInfoChanged tid cinfo
+       doOnTabGroup tid \gid -> do
+         void $ tellChild gid $ Tabs.TabInfoChanged tid cinfo
        pure (Just a)
 
     Tabs.TabDetached tid a -> do 
@@ -184,6 +251,11 @@ component =
     Tabs.TabAttached tab a -> do 
        handleQuery $ Tabs.TabCreated tab a
 
+    Tabs.TabDeactivated tid a -> do 
+       doOnTabGroup tid \gid -> do 
+          void $ tellChild gid $ Tabs.TabDeactivated tid
+       pure (Just a)
+
     where
         tellChild :: GroupId -> (H.Tell Tabs.Query) -> H.HalogenM State act Slots o m (Maybe Unit)
         tellChild gid q = H.query _tab gid $ H.tell q
@@ -197,3 +269,21 @@ component =
           case M.lookup tabId tabsToGroup of 
                Just groupId -> f groupId
                Nothing -> pure unit
+
+getPositionTabInGroup
+  :: Int
+  -> GroupId
+  -> Array (Tuple TabId GroupId)
+  -> Int
+getPositionTabInGroup index gid = 
+  (A.take $ index + 1)
+     >>> (A.filter \(Tuple _ gid') -> gid' == gid)  
+     >>> A.length
+     >>> (flip (-) $ 1)
+
+getPositionTab 
+  :: TabId
+  -> GroupId
+  -> Array (Tuple TabId GroupId)
+  -> Maybe Int
+getPositionTab tid gid arr = A.findIndex (\(Tuple tid' gid') -> tid' == tid && gid' == gid) arr

src/Sidebar/Components/Tabs.purs

@@ -7,7 +7,7 @@ import Control.Alt ((<$>))
 import Control.Alternative (empty, pure, (*>))
 import Control.Bind (bind, discard, (>=>), (>>=))
 import Control.Category (identity, (<<<), (>>>))
-import Data.Array (mapWithIndex, catMaybes, deleteAt, filter, findIndex, head, insertAt, modifyAt, (!!), length) as A
+import Data.Array (catMaybes, deleteAt, filter, findIndex, head, insertAt, length, mapWithIndex, modifyAt) as A
 import Data.Eq ((/=), (==))
 import Data.Function (flip, ($))
 import Data.Lens (over)
@@ -34,6 +34,7 @@ import Halogen.HTML.Properties as HP
 import Prelude (negate, sub)
 import PureTabs.Model.Events (SidebarEvent(..))
 import PureTabs.Model.GlobalState (_tabs)
+import Sidebar.Utils (moveElem)
 import Web.Event.Event (Event)
 import Web.Event.Event as Event
 import Web.HTML.Event.DataTransfer as DT
@@ -45,10 +46,11 @@ data Query a
   | TabCreated Tab a
   | TabDeleted TabId a
   | TabActivated (Maybe TabId) TabId a
-  | TabMoved TabId Int Int a
+  | TabMoved TabId Int a
   | TabInfoChanged TabId ChangeInfo a
   | TabDetached TabId a
   | TabAttached Tab a
+  | TabDeactivated TabId a
 
 data Output 
   = TabsSidebarAction SidebarEvent
@@ -104,7 +106,12 @@ component =
     }
 
 initialState :: forall i. i -> State
-initialState _ = { tabs: empty, selectedElem: Nothing, tabHovered: Nothing, leaveDebounce: Nothing }
+initialState _ = 
+  { tabs: empty
+  , selectedElem: Nothing
+  , tabHovered: Nothing
+  , leaveDebounce: Nothing 
+  }
 
 debounceTimeout :: Milliseconds -> AVar Unit -> Aff (Fiber Unit)
 debounceTimeout ms var =
@@ -369,30 +376,29 @@ handleQuery = case _ of
       )
       *> pure (Just a)
 
-  TabMoved tid prev next a -> do
-    state <- H.get
-    let
-      tab' = state.tabs A.!! prev
-    maybeFlipped tab' (pure unit) \tab -> do
-      H.modify_
-        ( over _tabs \tabs ->
-            fromMaybe tabs $ (A.deleteAt prev >=> A.insertAt next tab) tabs
-        )
-      -- Wait for a move to disable the drag data, otherwise the tab will come
-      -- back briefly to its original place before switching again.
-      -- This also means that if the move fail, this will be in an inconsistant
-      -- state.
-      H.modify_ \s -> s { selectedElem = Nothing }
+  TabMoved tid next a -> do
+    H.modify_ \s -> 
+       let 
+           newTabs = do 
+              tabPosition <- A.findIndex (\(Tab t) -> t.id == tid) s.tabs
+              moveElem tabPosition next s.tabs
+        in 
+          -- Regarding `selectedElem = Nothing`:
+          -- Wait for a move to disable the drag data, otherwise the tab will come
+          -- back briefly to its original place before switching again.
+          -- This also means that if the move fail, this will be in an inconsistant
+          -- state.
+          s { tabs = fromMaybe s.tabs newTabs, selectedElem = Nothing}
     pure (Just a)
 
-  TabInfoChanged tid cinfo a ->
+  TabInfoChanged tid cinfo a -> do
     H.modify_
       ( over _tabs
           $ \tabs ->
               fromMaybe tabs
                 $ (findIndexTabId tid >=> \index -> A.modifyAt index (updateTabFromInfo cinfo) tabs) tabs
       )
-      *> pure (Just a)
+    pure (Just a)
 
   TabDetached tid a -> 
     handleQuery $ TabDeleted tid a
@@ -401,6 +407,18 @@ handleQuery = case _ of
     H.liftEffect (log $ "sb: tab attached " <> (showTabId tab))
     handleQuery $ TabCreated tab a
 
+  TabDeactivated tid a -> do
+    H.modify_ \s ->
+      let 
+        updateTab tabs = do 
+          idx <- findIndexTabId tid tabs 
+          A.modifyAt idx (setTabActive false) tabs
+       in
+        s { tabs = fromMaybe s.tabs $ updateTab s.tabs }
+    pure (Just a)
+
+
+
 setTabActive :: Boolean -> Tab -> Tab
 setTabActive act (Tab t) = Tab (t { active = act })
 
@@ -416,9 +434,6 @@ findIndexTabId tid = A.findIndex \(Tab t) -> t.id == tid
 applyAtTabId :: TabId -> (Int -> Array Tab -> Maybe (Array Tab)) -> Array Tab -> Array Tab
 applyAtTabId tid f a = fromMaybe a $ findIndexTabId tid a >>= (flip f) a
 
-maybeFlipped :: forall a b. Maybe a -> b -> (a -> b) -> b
-maybeFlipped ma b f = maybe b f ma
-
 updateTabFromInfo :: ChangeInfo -> Tab -> Tab
 updateTabFromInfo (ChangeInfo cinfo) (Tab t) =
   let
@@ -437,8 +452,3 @@ updateTabFromInfo (ChangeInfo cinfo) (Tab t) =
         >>> updateField { acc: _.favIconUrl, update: (\val -> _ { favIconUrl = Just val }) }
   in
     Tab (applyChange t)
-
-moveElem :: forall a. Int -> Int -> Array a -> Maybe (Array a)
-moveElem from to arr = do
-  elem <- arr A.!! from
-  (A.deleteAt from >=> A.insertAt to elem) arr

src/Sidebar/Sidebar.purs

@@ -59,7 +59,7 @@ onBackgroundMsgConsumer query =
           void $ query $ H.tell $ Tabs.TabActivated prev next
           pure Nothing
         BgTabMoved tabId prev next -> do
-          void $ query $ H.tell $ Tabs.TabMoved tabId prev next
+          void $ query $ H.tell $ Tabs.TabMoved tabId next
           pure Nothing
         BgTabUpdated tabId cinfo tab -> do
           void $ query $ H.tell $ Tabs.TabInfoChanged tabId cinfo

src/Sidebar/Utils.purs

@@ -1,7 +1,15 @@
-module Sidebar.Utils (whenC) where 
+module Sidebar.Utils (whenC, moveElem) where 
 
+import Data.Array ((!!), insertAt, deleteAt) as A
+import Data.Maybe (Maybe)
 import Halogen (ClassName(..))
+import Prelude (bind, (>=>))
 
 
 whenC :: Boolean -> ClassName -> ClassName
 whenC b c = if b then c else ClassName ""
+
+moveElem :: forall a. Int -> Int -> Array a -> Maybe (Array a)
+moveElem from to arr = do
+  elem <- arr A.!! from
+  (A.deleteAt from >=> A.insertAt to elem) arr