feat: (re-)implement drag and drop, double click on empty zone for new tab

src/Background.purs

@@ -282,7 +282,7 @@ onNewWindowId port stateRef listenerRef winId = do
     )
     (M.lookup winId latestState.windows)
   --  add the new onMessage listener
-  sidebarListener <- Runtime.onMessageJsonAddListener port $ manageSidebar stateRef port
+  sidebarListener <- Runtime.onMessageJsonAddListener port $ manageSidebar stateRef winId port
   onDisconnectListener <- mkListenerUnit $ onDisconnect stateRef winId sidebarListener
   Runtime.portOnDisconnect port onDisconnectListener
 
@@ -298,16 +298,13 @@ initWindowState port ref winId =
 
 -- TODO don't pass the full ref, but only a set of function to manipulate/access 
 -- the data required
-manageSidebar :: (Ref.Ref GlobalState) -> Runtime.Port -> SidebarEvent -> Effect Unit
-manageSidebar stateRef port (SbDeleteTab tabId) = launchAff_ $ removeOne tabId
-
-manageSidebar stateRef port (SbActivateTab tabId) = launchAff_ $ activateTab tabId
-
-manageSidebar stateRef port (SbMoveTab tabId newIndex) = moveTab tabId { index: newIndex }
-
-manageSidebar stateRef port (SbCreateTab winId) = createTab { windowId: winId }
-
-manageSidebar stateRef port msg = pure unit
+manageSidebar :: (Ref.Ref GlobalState) -> WindowId -> Runtime.Port -> SidebarEvent -> Effect Unit
+manageSidebar _ winId port = case _ of 
+  SbDeleteTab tabId -> launchAff_ $ removeOne tabId
+  SbActivateTab tabId -> launchAff_ $ activateTab tabId
+  SbMoveTab tabId newIndex -> moveTab tabId { index: newIndex }
+  SbCreateTab -> createTab { windowId: winId }
+  _ -> pure unit
 
 onDisconnect :: forall a. (Ref.Ref GlobalState) -> WindowId -> Listener a -> Effect Unit
 onDisconnect stateRef winId listener = Ref.modify_ (set (_windows <<< (at winId) <<< _Just <<< _port) Nothing) stateRef

src/Browser/Utils.js

@@ -32,3 +32,9 @@ exports.mkListenerThree = function (fn) {
     }
   }
 };
+
+exports.unsafeLog = function (data) {
+  console.log(">> this is unsafe:");
+  console.log(data);
+  return data;
+};

src/Browser/Utils.purs

@@ -10,6 +10,7 @@ module Browser.Utils
   , mkListenerTwo
   , mkListenerThree
   , unwrapForeign
+  , unsafeLog
   ) where
 
 import Control.Alt (map)
@@ -56,3 +57,5 @@ unwrapForeign d = case runExcept
     $ genericDecode (defaultOptions { unwrapSingleConstructors = true }) d of
   Left err -> throw $ intercalate ", " (map renderForeignError err)
   Right val -> pure val
+
+foreign import unsafeLog :: forall a. a

src/Model.purs

@@ -174,7 +174,7 @@ instance showBackgroundEvent :: Show BackgroundEvent where
 data SidebarEvent
   = SbDeleteTab TabId
   | SbActivateTab TabId
-  | SbCreateTab WindowId
+  | SbCreateTab
   | SbMoveTab TabId Int
   | SbDetacheTab
   | SbCreatedGroup

src/Sidebar/Components/Tabs.purs

@@ -1,24 +1,22 @@
 module PureTabs.Sidebar.Tabs (component, Query(..)) where
 
-import Browser.Tabs (Tab(..), TabId(..))
+import Browser.Tabs (Tab(..), TabId)
 import Browser.Tabs.OnUpdated (ChangeInfo(..), ChangeInfoRec)
 import CSS.Background as CssBackground
-import Control.Alt ((<#>), (<$>), (<|>))
-import Control.Alternative (empty, pure, (*>), (<*>))
+import Control.Alt ((<$>))
+import Control.Alternative (empty, pure, (*>))
 import Control.Bind (bind, discard, (>=>), (>>=))
 import Control.Category (identity, (<<<), (>>>))
-import Data.Array (catMaybes, deleteAt, filter, findIndex, head, insertAt, modifyAt, (!!)) as A
-import Data.Array (foldl)
-import Data.Const (Const(..))
-import Data.Eq ((==))
-import Data.Function (const, flip, (#), ($))
+import Data.Array (mapWithIndex, catMaybes, deleteAt, filter, findIndex, head, insertAt, modifyAt, (!!)) as A
+import Data.Eq ((/=), (==))
+import Data.Function (flip, ($))
 import Data.Lens (over)
 import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.MediaType.Common (textPlain)
+import Data.Monoid ((<>))
 import Data.Show (show)
 import Data.Symbol (SProxy(..))
 import Data.Unit (Unit, unit)
-import Data.Void (Void)
-import Effect.Aff.Class (class MonadAff)
 import Effect.Class (class MonadEffect)
 import Effect.Class.Console (log)
 import Halogen as H
@@ -26,11 +24,11 @@ import Halogen.HTML as HH
 import Halogen.HTML.CSS as CSS
 import Halogen.HTML.Events as HE
 import Halogen.HTML.Properties as HP
-import PureTabs.Model (BackgroundEvent(..), SidebarEvent(..))
-import PureTabs.Model (_tabs)
-import PureTabs.Sidebar.Tab as TabC
+import PureTabs.Model (SidebarEvent(..), _tabs)
 import Web.Event.Event (Event)
 import Web.Event.Event as Event
+import Web.HTML.Event.DataTransfer as DT
+import Web.HTML.Event.DragEvent as DE
 import Web.UIEvent.MouseEvent (toEvent) as ME
 
 data Query a
@@ -44,9 +42,20 @@ data Query a
 data Action
   = UserClosedTab TabId Event
   | UserActivatedTab TabId Event
+  | UserOpenedTab Event
+  | TabDragStart DE.DragEvent Tab Int
+  | TabDragOver DE.DragEvent Int
+  | TabDragEnd DE.DragEvent
+
+type DraggedTab
+  = { tab :: Tab
+    , originalIndex :: Int
+    , overIndex :: Int
+    }
 
 type State
   = { tabs :: Array Tab
+    , selectedElem :: Maybe DraggedTab
     }
 
 component :: forall i m. MonadEffect m => H.Component HH.HTML Query i SidebarEvent m
@@ -63,21 +72,33 @@ component =
     }
 
 initialState :: forall i. i -> State
-initialState _ = { tabs: empty }
+initialState _ = { tabs: empty, selectedElem: Nothing }
 
 _tab :: SProxy "tab"
 _tab = SProxy
 
 render :: forall m. State -> H.ComponentHTML Action () m
 render state =
-  HH.div
-    [ HP.id_ "tabs"
-    ]
-    (renderTab <$> state.tabs)
+  let
+    tabsWithIndex = state.tabs
+
+    tabs =
+      fromMaybe tabsWithIndex
+        $ state.selectedElem
+        >>= ( \{ originalIndex, overIndex } -> moveElem originalIndex overIndex tabsWithIndex
+          )
+  in
+    HH.div
+      [ HP.id_ "tabs", HE.onDoubleClick (\ev -> Just (UserOpenedTab $ ME.toEvent ev)) ]
+      (A.mapWithIndex renderTab tabs)
   where
-  renderTab (Tab t) =
+  renderTab index (Tab t) =
     HH.div
       [ HP.id_ $ show t.id
+      , HP.draggable true
+      , HE.onDragStart \evt -> Just $ TabDragStart evt (Tab t) index
+      , HE.onDragEnd \evt -> Just $ TabDragEnd evt
+      , HE.onDragOver \evt -> Just $ TabDragOver evt index
       , HE.onClick (\ev -> Just (UserActivatedTab t.id (ME.toEvent ev)))
       , HP.classes $ H.ClassName
           <$> A.catMaybes
@@ -118,21 +139,57 @@ render state =
 handleAction :: forall m. MonadEffect m => Action -> H.HalogenM State Action () SidebarEvent m Unit
 handleAction = case _ of
   UserClosedTab tid ev -> do
-    H.liftEffect $ do 
-        Event.preventDefault ev 
-        Event.stopPropagation ev
-    H.liftEffect $ log "sb: closed a tab"
+    H.liftEffect
+      $ do
+          Event.preventDefault ev
+          Event.stopPropagation ev
+          log "sb: closed a tab"
     H.raise $ SbDeleteTab tid
   UserActivatedTab tid ev -> do
-    H.liftEffect $ do 
-        Event.preventDefault ev 
-        Event.stopPropagation ev
-    H.liftEffect $ log "sb: activated a tab"
+    H.liftEffect
+      $ do
+          Event.preventDefault ev
+          Event.stopPropagation ev
+          log "sb: activated a tab"
     H.raise $ SbActivateTab tid
+  UserOpenedTab ev -> do
+    H.liftEffect
+      $ do
+          Event.preventDefault ev
+          Event.stopPropagation ev
+          log "sb: created a tab"
+    H.raise SbCreateTab
+  TabDragStart dragEvent tab index -> do
+    let
+      dataTransfer = DE.dataTransfer dragEvent
+    H.liftEffect
+      $ do
+          DT.setData textPlain "" dataTransfer
+          DT.setDropEffect DT.Move dataTransfer
+    H.modify_ \s -> s { selectedElem = Just { tab: tab, originalIndex: index, overIndex: index } }
+    H.liftEffect $ log $ "sb: drag start from " <> (show index)
+  TabDragOver event index -> do
+    -- prevent the ghost from flying back to its (wrong) place
+    -- see https://stackoverflow.com/questions/42725321/prevent-html5-drag-ghost-image-flying-back
+    H.liftEffect $ Event.preventDefault (DE.toEvent event)
+    state <- H.get
+    case state.selectedElem of
+      Just selectedRec@{ originalIndex, overIndex }
+        | overIndex /= index -> do
+          H.modify_ (\s -> s { selectedElem = Just $ selectedRec { overIndex = index } })
+          H.liftEffect $ log $ "sb: drag over from " <> (show overIndex) <> " to " <> (show index)
+      _ -> pure unit
+  TabDragEnd event -> do
+    state <- H.get
+    case state.selectedElem of
+      Nothing -> pure unit
+      Just { tab: (Tab t), originalIndex, overIndex } -> do
+        H.liftEffect $ log $ "sb: drag end from " <> (show originalIndex) <> " to " <> (show overIndex)
+        H.raise (SbMoveTab t.id overIndex)
 
 handleQuery :: forall act o m a. Query a -> H.HalogenM State act () o m (Maybe a)
 handleQuery = case _ of
-  InitialTabList tabs a -> H.put { tabs } *> pure (Just a)
+  InitialTabList tabs a -> H.modify_ (\s -> s { tabs = tabs }) *> pure (Just a)
   TabCreated (Tab t) a ->
     H.modify_
       (over _tabs $ \tabs -> fromMaybe tabs $ A.insertAt t.index (Tab t) tabs)
@@ -141,7 +198,6 @@ handleQuery = case _ of
     H.modify_
       ( over _tabs
           $ applyAtTabId tid A.deleteAt
-      {-- $ \tabs -> fromMaybe tabs $ findIndexTabId tid tabs >>= (flip A.deleteAt) tabs --}
       )
       *> pure (Just a)
   TabActivated oldTid tid a ->
@@ -155,11 +211,16 @@ handleQuery = case _ of
     state <- H.get
     let
       tab' = state.tabs A.!! prev
-    maybeFlipped tab' (pure unit) \tab ->
+    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 }
     pure (Just a)
   TabInfoChanged tid cinfo a ->
     H.modify_
@@ -206,3 +267,8 @@ 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