feat(sidebar): implement moving a tab to an other group

Initial implementation, it doesn't support dragging a tab at a specific
place, but it works.

src/Sidebar/Components/Bar.purs

@@ -1,13 +1,16 @@
 module PureTabs.Sidebar.Bar where
 
-import Browser.Tabs (Tab(..), TabId)
+import Browser.Tabs (Tab(..), TabId(..))
 import Control.Alternative (pure)
-import Control.Bind (bind, discard, map, void, (<#>))
+import Control.Bind (bind, discard, map, void, (*>), (<#>))
 import Data.Array ((:))
 import Data.Array as A
+import Data.Eq ((/=))
 import Data.Function (($))
 import Data.Map as M
 import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.MediaType.Common (textPlain)
+import Data.Number (fromString)
 import Data.Set (toUnfoldable, Set) as S
 import Data.Set.NonEmpty (cons, max) as NES
 import Data.Symbol (SProxy(..))
@@ -27,6 +30,9 @@ import PureTabs.Sidebar.Tabs (Output(..))
 import PureTabs.Sidebar.Tabs as Tabs
 import Sidebar.Component.GroupName as GroupName
 import Sidebar.Utils (moveElem, whenC)
+import Web.HTML.Event.DataTransfer as DT
+import Web.HTML.Event.DragEvent as DE
+
 
 newtype GroupId
   = GroupId Int
@@ -47,6 +53,7 @@ type State
     , tabsToGroup :: M.Map TabId GroupId
     , groupTabsPositions :: Array (Tuple TabId GroupId)
     , currentGroup :: GroupId
+    , draggedCurrentGroup :: Maybe GroupId
     }
 
 data Action
@@ -55,6 +62,8 @@ data Action
   | UserCreatedGroup
   | UserDeletedGroup GroupId
   | HandleTabsOutput GroupId Tabs.Output
+  | GroupNameDragOver DE.DragEvent GroupId
+  | DragEnd DE.DragEvent
 
 initialState :: forall i. i -> State
 initialState _ =
@@ -66,6 +75,7 @@ initialState _ =
       , tabsToGroup: M.empty
       , groupTabsPositions : []
       , currentGroup: firstGroupId 
+      , draggedCurrentGroup: Nothing
     }
 
 type Slots
@@ -94,6 +104,8 @@ component =
   render :: State -> H.ComponentHTML Action Slots m
   render state = 
     let 
+        currentGroupShown = fromMaybe state.currentGroup state.draggedCurrentGroup
+
         menuElem attrs text = HH.li attrs [ HH.text text]
 
         topMenu = HH.div [ HP.id_ "bar-menu" ] [
@@ -101,16 +113,16 @@ component =
         ]
 
         barListGroup = HH.div [ HP.id_ "bar-list" ] [HH.ul [ HP.id_ "bar-list-group"] $ 
-          (M.toUnfoldable state.groups) <#> \(Tuple gid g) -> renderGroup gid (gid == state.currentGroup) g
+          (M.toUnfoldable state.groups) <#> \(Tuple gid g) -> renderGroup gid (gid == currentGroupShown) g
         ]
 
         tabsDivs = (S.toUnfoldable $ (M.keys state.groups)) <#> 
           (\gid -> HH.div [
-            HP.classes [(H.ClassName "bar-tabs"), whenC (gid == state.currentGroup) (H.ClassName "bar-tabs-active")] 
+            HP.classes [(H.ClassName "bar-tabs"), whenC (gid == currentGroupShown) (H.ClassName "bar-tabs-active")] 
           ] [renderGroupTabs gid])
     
      in
-        HH.div [ HP.id_ "bar" ] $ topMenu : barListGroup : tabsDivs 
+        HH.div [ HP.id_ "bar", HE.onDragEnd \evt -> Just $ DragEnd evt ] $ topMenu : barListGroup : tabsDivs 
 
   renderGroupTabs :: GroupId -> H.ComponentHTML Action Slots m
   renderGroupTabs groupId = HH.slot _tab groupId Tabs.component unit (Just <<< (HandleTabsOutput groupId))
@@ -120,9 +132,10 @@ component =
     HH.li [ 
       HP.classes [(H.ClassName "group-name"), whenC isActive (H.ClassName "active-group")]
       , HE.onClick (\_ -> Just (UserSelectedGroup groupId))
+      , HE.onDragOver \evt -> Just $ GroupNameDragOver evt groupId
     ] [ HH.slot _groupName groupId GroupName.component group.name (\newName -> Just (UserRenameGroup groupId newName))] 
 
-  handleAction :: Action -> H.HalogenM State Action Slots SidebarEvent m Unit
+  handleAction :: MonadEffect m => Action -> H.HalogenM State Action Slots SidebarEvent m Unit
   handleAction = 
     case _ of
 
@@ -143,32 +156,35 @@ component =
 
          UserDeletedGroup gid -> pure unit
 
-         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
+         GroupNameDragOver dragEvent gid -> do
+           let 
+               dataTransfer = DE.dataTransfer dragEvent
+           dragData <- H.liftEffect $ DT.getData textPlain dataTransfer
+           case fromString dragData of
+                Nothing -> H.liftEffect $ log $ "sb: group drag over, got something else than a number: " <> dragData
+                Just tid -> do 
+                   H.modify_ _ { draggedCurrentGroup = Just gid }
+                   H.liftEffect $ log $ "sb: dragging " <> (show tid) <> " over " <> (show gid)
+
+         DragEnd evt -> do 
+            H.modify_ _ { draggedCurrentGroup = Nothing }
+            H.liftEffect $ log $ "sb: drag end from bar component"
+
+         HandleTabsOutput gid output -> 
+           case output of 
+              OutputTabDragEnd tid' -> 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
-
-                   newIndex # maybe (pure unit) \idx -> do
-                     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) <> ")"
-
-                _ -> H.raise sbEvent
+                   case Tuple tid' s.draggedCurrentGroup of 
+                        -- Only perform a move when we're dragging a tab onto a different group
+                        Tuple (Just tid) (Just draggedGroup) | s.currentGroup /= draggedGroup -> 
+                                 moveTabToGroup tid gid draggedGroup s
+                        _ -> pure unit
+
+                   H.modify_ _ { draggedCurrentGroup = Nothing }
+
+
+              TabsSidebarAction (SbMoveTab tid groupIndex) -> sidebarMoveTab tid gid groupIndex
+              TabsSidebarAction sbEvent -> H.raise sbEvent
 
     where
           findNextGroupId :: S.Set GroupId -> GroupId
@@ -176,6 +192,72 @@ component =
             let GroupId(maxValue) = NES.max (NES.cons (GroupId 0) values)
              in GroupId(maxValue + 1)
 
+          moveTabToGroup 
+            :: MonadEffect m => TabId 
+            -> GroupId 
+            -> GroupId 
+            -> State 
+            -> H.HalogenM State Action Slots SidebarEvent m Unit
+          moveTabToGroup tid fromGroup toGroup state = do
+            let 
+                -- XXX: The goal is to put it at the end, but if you:
+                --  - create a new group
+                --  - drag a tab from the first one to it
+                --  - drag it back to the first group
+                --  Then it will be at the beginning of the group, not the end.
+
+                -- Right now we only put it at the end of the list. 
+                -- We don't support dragging at a specific place.
+                newTabIndex = 
+                  fromMaybe (A.length state.groupTabsPositions) 
+                  $ lastWinTabIndexInGroup toGroup state.groupTabsPositions
+
+            s <- H.modify \s -> 
+              s { tabsToGroup = M.update (\_ -> Just toGroup) tid s.tabsToGroup
+              , groupTabsPositions = 
+                s.groupTabsPositions
+                <#> 
+                (\(Tuple tid' gid') -> if tid' == tid then Tuple tid' toGroup else Tuple tid' gid') 
+              -- Reassign the current group directly here to avoid flickering
+              , currentGroup = toGroup
+              }
+            let newIndexInGroup = getPositionTabInGroup newTabIndex toGroup s.groupTabsPositions
+
+            deletedTab' <- H.query _tab fromGroup $ H.request $ Tabs.TabDeleted tid
+            case deletedTab' of 
+                 Just (Just (Tab tab)) -> 
+                   void $ H.query _tab toGroup $ H.tell 
+                    $ Tabs.TabCreated $ Tab (tab { index = newIndexInGroup })
+                 _ -> pure unit
+
+            H.raise $ SbMoveTab tid newTabIndex
+            H.raise $ SbActivateTab tid
+
+          sidebarMoveTab 
+            :: TabId 
+            -> GroupId 
+            -> Int 
+            -> H.HalogenM State Action Slots SidebarEvent m Unit
+          sidebarMoveTab tid gid 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
+
+             -- 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.
+             newIndex # maybe (pure unit) \idx -> H.raise $ SbMoveTab tid idx 
+
+ 
+
   handleQuery :: forall act a. Tabs.Query a -> H.HalogenM State act Slots SidebarEvent m (Maybe a)
   handleQuery = case _ of
 
@@ -214,7 +296,7 @@ component =
        void $ tellChild newS.currentGroup $ Tabs.TabCreated newTab
        pure (Just a)
 
-    Tabs.TabDeleted tid a -> do 
+    Tabs.TabDeleted tid reply -> do 
        doOnTabGroup tid \gid -> do 
          H.modify_ (\s -> s 
                        { tabsToGroup = M.delete tid s.tabsToGroup 
@@ -225,8 +307,8 @@ component =
                           (Tuple tid s.currentGroup)
                           s.groupTabsPositions
                        })
-         void $ tellChild gid $ Tabs.TabDeleted tid
-       pure (Just a)
+         void $ H.query _tab gid $ H.request $ Tabs.TabDeleted tid
+       pure (Just (reply Nothing))
 
     Tabs.TabActivated prevTid' tid a -> do 
        case prevTid' of
@@ -259,7 +341,7 @@ component =
        pure (Just a)
 
     Tabs.TabDetached tid a -> do 
-       handleQuery $ Tabs.TabDeleted tid a
+       handleQuery $ Tabs.TabDeleted tid \_ -> a
 
     Tabs.TabAttached tab a -> do 
        handleQuery $ Tabs.TabCreated tab a
@@ -267,6 +349,9 @@ component =
     where
         tellChild :: GroupId -> (H.Tell Tabs.Query) -> H.HalogenM State act Slots SidebarEvent m (Maybe Unit)
         tellChild gid q = H.query _tab gid $ H.tell q
+        -- 
+        -- requestChild :: GroupId -> (H.Request Tabs.Query) -> H.HalogenM State act Slots SidebarEvent M (Maybe a)
+        -- requestChild gid q = H.request 
 
         doOnTabGroup 
           :: TabId 
@@ -304,3 +389,15 @@ getTabIdsOfGroup gid =
   M.toUnfoldable 
   >>> A.filter (\(Tuple tid gid') -> gid' == gid)
   >>> map T.fst
+
+--| Obtain the window index of the last tab of a group.
+lastWinTabIndexInGroup 
+  :: GroupId
+  -> Array (Tuple TabId GroupId)
+  -> Maybe Int
+lastWinTabIndexInGroup gid = 
+  A.mapWithIndex (Tuple)
+    >>> A.filter (T.snd >>> T.snd >>> (==) gid)
+    >>> map T.fst
+    >>> A.head
+

src/Sidebar/Components/Tabs.purs

@@ -42,7 +42,7 @@ import Web.UIEvent.MouseEvent as ME
 data Query a
   = InitialTabList (Array Tab) a
   | TabCreated Tab a
-  | TabDeleted TabId a
+  | TabDeleted TabId (Maybe Tab -> a)
   | TabActivated (Maybe TabId) TabId a
   | TabMoved TabId Int a
   | TabInfoChanged TabId ChangeInfo a
@@ -51,6 +51,9 @@ data Query a
 
 data Output 
   = TabsSidebarAction SidebarEvent
+  -- Nothing if we already did the move
+  -- Just TabId in case the dragged ended somewhere else
+  | OutputTabDragEnd (Maybe TabId)
 
 data Action
   = UserClosedTab TabId Event
@@ -308,7 +311,7 @@ handleAction = case _ of
       dataTransfer = DE.dataTransfer dragEvent
     H.liftEffect
       $ do
-          DT.setData textPlain "" dataTransfer
+          DT.setData textPlain (showTabId tab) dataTransfer
           DT.setDropEffect DT.Move dataTransfer
     H.modify_ _ { selectedElem = Just { tab: tab, originalIndex: index, overIndex: Just index }, tabHovered = Nothing }
     H.liftEffect $ log $ "sb: drag start from " <> (show index)
@@ -341,16 +344,23 @@ handleAction = case _ of
     cancelLeaveDebounce state
     case state.selectedElem of
       Nothing -> pure unit
+
       -- On success, we don't remove the dragged element here. It is instead done in the
       -- query handler for TabMoved. See comment there for the explanation.
-      Just { tab: (Tab t), originalIndex, overIndex: (Just overIndex) } -> H.raise $ TabsSidebarAction (SbMoveTab t.id overIndex)
-      Just { overIndex: Nothing } -> H.modify_ _ { selectedElem = Nothing }
+      Just { tab: (Tab t), originalIndex, overIndex: (Just overIndex) } -> do
+        H.raise $ TabsSidebarAction (SbMoveTab t.id overIndex)
+        H.raise $ OutputTabDragEnd Nothing
+        H.liftEffect $ log "sb: drag end (asking to do a move)"
+
+      Just { tab: (Tab t), overIndex: Nothing } -> do
+        H.modify_ _ { selectedElem = Nothing }
+        H.raise $ OutputTabDragEnd $ Just t.id
+        H.liftEffect $ log "sb: drag end (doing nothing)"
 
   TabDragLeave event -> runDebounce $ TabDragLeaveRun event
 
   TabDragLeaveRun event -> do
     state <- H.get
-    H.liftEffect $ log "actually running drag leave"
     case state.selectedElem of
       Just selectedRec@{ overIndex: (Just overIndex) } -> H.modify_ _ { selectedElem = Just $ selectedRec { overIndex = Nothing } }
       _ -> pure unit
@@ -380,9 +390,11 @@ handleQuery = case _ of
       s { tabs = fromMaybe s.tabs $ A.insertAt t.index (Tab t) s.tabs}
     pure (Just a)
 
-  TabDeleted tid a -> do
+  TabDeleted tid reply -> do
+    { tabs } <- H.get
+    let deletedTab = findTabByTabId tid tabs
     H.modify_ \s -> s { tabs = applyAtTabId tid A.deleteAt s.tabs}
-    pure (Just a)
+    pure (Just (reply deletedTab))
 
   TabActivated prevTid tid a -> do
     let 
@@ -414,8 +426,8 @@ handleQuery = case _ of
         }
     pure (Just a)
 
-  TabDetached tid a -> 
-    handleQuery $ TabDeleted tid a
+  TabDetached tid reply -> 
+    handleQuery $ TabDeleted tid \_ -> reply
 
   TabAttached tab a -> do
     H.liftEffect (log $ "sb: tab attached " <> (showTabId tab))

src/Sidebar/Sidebar.purs

@@ -52,7 +52,7 @@ onBackgroundMsgConsumer query =
           void $ query $ H.tell $ Tabs.TabCreated tab
           pure Nothing
         BgTabDeleted tabId -> do
-          void $ query $ H.tell $ Tabs.TabDeleted tabId
+          void $ query $ H.request $ Tabs.TabDeleted tabId
           pure Nothing
         BgTabActivated prev next -> do
           void $ query $ H.tell $ Tabs.TabActivated prev next