feat: drag and drop to move tabs

README.md

@@ -13,7 +13,7 @@ maintainable way. Any criticism is welcome.
 - [x] Support favicon
 - [x] Add delete button
 - [x] Tab selection
-- [ ] Moving a tab
+- [x] Moving a tab
 - [ ] Detaching a tab
 - [ ] Actually show tabs as a tree
 - [ ] Session save/import

package-lock.json

@@ -6568,6 +6568,11 @@
         }
       }
     },
+    "sortablejs": {
+      "version": "1.10.2",
+      "resolved": "https://registry.npmjs.org/sortablejs/-/sortablejs-1.10.2.tgz",
+      "integrity": "sha512-YkPGufevysvfwn5rfdlGyrGjt7/CRHwvRPogD/lC+TnvcN29jDpCifKP+rBqf+LRldfXSTh+0CGLcSg0VIxq3A=="
+    },
     "source-map": {
       "version": "0.6.1",
       "resolved": "https://registry.npmjs.org/source-map/-/source-map-0.6.1.tgz",

package.json

@@ -16,5 +16,8 @@
   "devDependencies": {
     "concurrently": "^5.2.0",
     "parcel": "^1.12.4"
+  },
+  "dependencies": {
+    "sortablejs": "^1.10.2"
   }
 }

src/Background.purs

@@ -1,7 +1,7 @@
 module PureTabs.Background where
 
 import Browser.Runtime as Runtime
-import Browser.Tabs (Tab(..), TabId, WindowId, query, removeOne, activateTab)
+import Browser.Tabs (Tab(..), TabId, WindowId, query, removeOne, activateTab, moveTab)
 import Browser.Tabs.OnActivated as OnActivated
 import Browser.Tabs.OnCreated as OnCreated
 import Browser.Tabs.OnMoved as OnMoved
@@ -46,7 +46,7 @@ main = do
   runMain :: Aff Unit
   runMain = do
     allTabs <- query
-    liftEffect $ initializeBackground =<< (Ref.new $ tabsToGlobalState allTabs) 
+    liftEffect $ initializeBackground =<< (Ref.new $ tabsToGlobalState allTabs)
 
 initializeBackground :: Ref.Ref GlobalState -> Effect Unit
 initializeBackground ref = do
@@ -63,9 +63,9 @@ onTabCreated stateRef tab' = do
     Ref.modify
       ( set (_tabFromWindow tab') (Just tab')
           *> over (_positions >>> _windowIdToWindow tab.windowId)
-          -- TODO: throw an error here instead. Encapsulate the manipulations of
-          -- the position array to make sure we always perform valid operation
-          -- and otherwise throw an error or recover from it.
+              -- TODO: throw an error here instead. Encapsulate the manipulations of
+              -- the position array to make sure we always perform valid operation
+              -- and otherwise throw an error or recover from it.
               (\p -> maybe p identity (insertAt tab.index tab.id p))
       )
       stateRef
@@ -162,9 +162,10 @@ onTabDeleted stateRef tabId info = do
     deleteTabState t = set (_tabFromWindow t) Nothing
 
     deletePositionState :: Tab -> GlobalState -> GlobalState
-    deletePositionState (Tab t) = over 
-      (_positions >>> _windowIdToWindow t.windowId)
-      (\p -> maybe p identity (deleteAt t.index p))
+    deletePositionState (Tab t) =
+      over
+        (_positions >>> _windowIdToWindow t.windowId)
+        (\p -> maybe p identity (deleteAt t.index p))
 
     newState = foldr (\t -> deleteTabState t >>> deletePositionState t) state allTabs
   Ref.write newState stateRef
@@ -237,6 +238,8 @@ manageSidebar stateRef port (SbTabDeleted tabId) = launchAff_ $ removeOne tabId
 
 manageSidebar stateRef port (SbTabActived tabId) = launchAff_ $ activateTab tabId
 
+manageSidebar stateRef port (SbTabMoved tabId newIndex) = moveTab tabId {index: newIndex}
+
 manageSidebar stateRef port msg = pure unit
 
 onDisconnect :: forall a. (Ref.Ref GlobalState) -> WindowId -> Listener a -> Effect Unit

src/Browser/Tabs.js

@@ -20,3 +20,11 @@ exports["update'"] = function () {
     }
   };
 };
+
+exports["moveTab"] = function (tabIds) {
+  return function (moveProperties) {
+    return function () {
+      return browser.tabs.move(tabIds, moveProperties);
+    };
+  };
+};

src/Browser/Tabs.purs

@@ -1,4 +1,4 @@
-module Browser.Tabs (WindowId, TabId(..), Tab(..), query, remove, removeOne, update, activateTab) where
+module Browser.Tabs (WindowId, TabId(..), Tab(..), MoveProperties, query, remove, removeOne, update, activateTab, moveTab) where
 
 import Browser.Utils (unwrapForeign)
 import Control.Alt (map)
@@ -149,3 +149,10 @@ update props tabId = toAffE $ update' props tabId
 
 activateTab :: TabId -> Aff Tab
 activateTab tabId = update { active: true } tabId
+
+type MoveProperties = {
+  -- windowId :: Maybe WindowId
+  index :: Int
+}
+
+foreign import moveTab :: TabId -> MoveProperties -> Effect Unit

src/JQuery/Ext.js

@@ -16,3 +16,9 @@ exports.prepend = function(ob) {
     };
 };
 
+
+exports.getHtmlElem = function(ob) {
+  return function() {
+    return ob[0];
+  }
+}

src/JQuery/Ext.purs

@@ -1,8 +1,11 @@
-module JQuery.Ext (after, prepend) where
+module JQuery.Ext (after, prepend, getHtmlElem) where
 
-import Prelude (Unit)
 import Effect (Effect)
 import JQuery (JQuery)
+import Prelude (Unit)
+import Web.HTML (HTMLElement)
 
 foreign import after :: JQuery -> JQuery -> Effect Unit
 foreign import prepend :: JQuery -> JQuery -> Effect Unit
+-- XXX: should probably be a maybe ?
+foreign import getHtmlElem :: JQuery -> Effect HTMLElement

src/Model.purs

@@ -22,7 +22,7 @@ module PureTabs.Model
   ) where
 
 import Browser.Runtime (Port)
-import Browser.Tabs (TabId, WindowId, Tab(..))
+import Browser.Tabs (TabId(..), WindowId, Tab(..))
 import Browser.Tabs.OnUpdated (ChangeInfo(..))
 import Control.Alternative (empty)
 import Control.Bind (join)
@@ -164,7 +164,7 @@ data SidebarEvent
   = SbTabDeleted TabId
   | SbTabActived TabId
   | SbTabCreated
-  | SbTabMoved
+  | SbTabMoved TabId Int
   | SbTabDetached
   | SbGroupCreated
   | SbGroupDeleted

src/Sidebar.purs

@@ -1,17 +1,20 @@
 module PureTabs.Sidebar where
 
 import Browser.Runtime as Runtime
-import Browser.Tabs (Tab(..), TabId, WindowId)
+import Browser.Tabs (Tab(..), TabId(..), WindowId)
 import Browser.Tabs.OnUpdated (ChangeInfo(..))
 import Browser.Windows (getCurrent)
 import Control.Alternative (pure)
-import Control.Bind ((>=>), (>>=))
+import Control.Bind ((=<<), (>=>), (>>=))
+import Control.Category ((<<<))
+import Control.Monad (liftM1)
 import Data.CommutativeRing ((+))
 import Data.Eq ((==))
 import Data.Foldable (traverse_)
 import Data.Function (flip)
 import Data.Maybe (Maybe(..), maybe)
 import Data.Monoid ((<>))
+import Data.Number (fromString)
 import Data.Show (show)
 import Data.Unit (unit)
 import Debug.Trace (traceM)
@@ -19,10 +22,15 @@ import Effect (Effect)
 import Effect.Aff (Aff, launchAff_)
 import Effect.Class (liftEffect)
 import Effect.Console (log)
+import Effect.Exception (throw)
 import JQuery as J
-import JQuery.Ext (after, prepend) as J
+import JQuery.Ext (after, prepend, getHtmlElem) as J
 import Prelude (Unit, bind, ($), discard)
 import PureTabs.Model (BackgroundEvent(..), SidebarEvent(..))
+import Sortable (Sortable, create, Event) as S
+import Web.DOM.Element (id)
+import Web.HTML (HTMLElement)
+import Web.HTML.HTMLElement (toElement)
 
 main :: Effect Unit
 main = do
@@ -35,11 +43,21 @@ main = do
     currentWindow <- getCurrent
     liftEffect $ initSidebar port currentWindow.id
 
+sortableOnUpdate :: Runtime.Port -> S.Event -> Effect Unit
+sortableOnUpdate port { item: item, newIndex: Just newIndex } = do
+  sTabId <- id $ toElement item
+  case fromString sTabId of 
+       Nothing -> throw $ "couldn't convert to a tab id " <> sTabId
+       Just tabId' -> Runtime.postMessageJson port $ SbTabMoved (TabId tabId') newIndex
+sortableOnUpdate port _ = pure unit
+
 initSidebar :: Runtime.Port -> WindowId -> Effect Unit
 initSidebar port winId = do
   log $ "windowId " <> (show winId)
   Runtime.postMessageJson port $ SbHasWindowId winId
   _ <- Runtime.onMessageJsonAddListener port onMsg
+  allTabs <- J.getHtmlElem =<< J.select "#tabs"
+  sortable <- S.create { onUpdate: sortableOnUpdate port } allTabs
   pure unit
   where
   onMsg :: BackgroundEvent -> Effect Unit

src/Sortable/Sortable.js

@@ -0,0 +1,52 @@
+"use strict";
+
+var Sortable = require("../../node_modules/sortablejs/Sortable.min.js");
+
+const optionsEventField = [
+  "onChoose",
+  "onUnchoose",
+  "onStart",
+  "onEnd",
+  "onAdd",
+  "onUpdate",
+  "onSort",
+  "onRemove",
+  "onFilter",
+  "onClone",
+  "onChange",
+];
+const optionsEffectField = optionsEventField.concat(["onMove"]);
+
+exports["create'"] = function (options, el, parseEvent) {
+
+  const optionsCopy = Object.assign({}, options);
+  for (const field of optionsEffectField) {
+    if (field in optionsCopy) {
+      let func = optionsCopy[field];
+      if (optionsEventField.includes(field)) {
+        func = parseEvent(func);
+      }
+      optionsCopy[field] = unEffect(func);
+    }
+  }
+
+  return function () {
+    return Sortable.create(el, optionsCopy);
+  };
+};
+
+exports.isTrue = function (b) {
+  return b === true;
+};
+exports.isFalse = function (b) {
+  return b === false;
+};
+exports.isClone = function (b) {
+  return b === "clone";
+};
+const unEffect = function (f) {
+  return function (event) {
+    console.log(event);
+    return f(event)();
+  };
+};

src/Sortable/Sortable.purs

@@ -0,0 +1,158 @@
+module Sortable (Sortable, Options, Event, MoveEvent, PullMode, create) where
+
+import Control.Alt ((<$>))
+import Control.Alternative (pure)
+import Control.Bind ((>>=))
+import Control.Category ((<<<), (>>>))
+import Control.Monad.Except (mapExcept, runExcept, throwError)
+import Data.Array (intercalate)
+import Data.Boolean (otherwise)
+import Data.BooleanAlgebra ((||))
+import Data.Either (Either(..))
+import Data.Function (($))
+import Data.Function.Uncurried (Fn3, runFn3)
+import Data.List.NonEmpty (NonEmptyList(..))
+import Data.Maybe (Maybe(..))
+import Data.Symbol (class IsSymbol)
+import Data.Traversable (traverse)
+import Data.Unit (Unit)
+import Effect (Effect)
+import Effect.Exception (throw)
+import Foreign (F, Foreign, ForeignError(..), fail, isNull, isUndefined, readInt, readNull, readNullOrUndefined, readNumber, renderForeignError, tagOf, unsafeFromForeign)
+import Foreign.Index ((!))
+import Heterogeneous.Mapping (class MappingWithIndex)
+import Prelude (bind)
+import Prim.Row (class Union, class Cons) as Row
+import Web.HTML (HTMLElement)
+import Web.HTML.Event.DataTransfer (DataTransfer)
+import Web.HTML.HTMLElement (DOMRect)
+
+foreign import data Sortable :: Type
+
+foreign import isTrue :: Foreign -> Boolean
+
+foreign import isFalse :: Foreign -> Boolean
+
+foreign import isClone :: Foreign -> Boolean
+
+data PullMode
+  = Clone
+  | Bool Boolean
+  | NotDefined
+
+readPullMode :: Foreign -> F PullMode
+readPullMode value
+  | isNull value || isUndefined value = pure NotDefined
+  | isTrue value = pure (Bool true)
+  | isFalse value = pure (Bool false)
+  | isClone value = pure Clone
+  | otherwise = fail $ TypeMismatch "PullMode" (tagOf value)
+
+type Event
+  = { to :: HTMLElement
+    , from :: HTMLElement
+    , item :: HTMLElement
+    , clone :: HTMLElement
+    , oldIndex :: Maybe Int
+    , newIndex :: Maybe Int
+    , oldDraggableIndex :: Maybe Int
+    , newDraggableIndex :: Maybe Int
+    , pullMode :: PullMode
+    }
+
+{-- foreign import data ForeignEvent :: Type --}
+readEvent :: Foreign -> F Event
+readEvent value = do
+  to <- value ! "to" >>= (pure <<< unsafeFromForeign)
+  from <- value ! "from" >>= (pure <<< unsafeFromForeign)
+  item <- value ! "item" >>= (pure <<< unsafeFromForeign)
+  clone <- value ! "clone" >>= (pure <<< unsafeFromForeign)
+  oldIndex <- value ! "oldIndex" >>= readNullOrUndefined >>= traverse readInt
+  newIndex <- value ! "newIndex" >>= readNullOrUndefined >>= traverse readInt
+  oldDraggableIndex <- value ! "oldDraggableIndex" >>= readNullOrUndefined >>= traverse readInt
+  newDraggableIndex <- value ! "newDraggableIndex" >>= readNullOrUndefined >>= traverse readInt
+  pullMode <- value ! "pullMode" >>= readPullMode
+  pure { to, from, item, clone, oldIndex, newIndex, oldDraggableIndex, newDraggableIndex, pullMode }
+
+type MoveEvent
+  = { to :: HTMLElement
+    , from :: HTMLElement
+    , dragged :: HTMLElement
+    , draggedRect :: DOMRect
+    , related :: HTMLElement
+    , relatedRect :: DOMRect
+    , willInsertAfter :: Boolean
+    }
+
+type Options
+  = ( group :: String
+    , sort :: Boolean
+    , delay :: Int
+    , delayOnTouchOnly :: Boolean
+    , touchStartThreshold :: Int
+    , disabled :: Boolean
+    , {-- store ::  --} animation :: Int
+    , easing :: String
+    , handle :: String
+    , filter :: String
+    , preventOnFilter :: Boolean
+    , draggable :: String
+    , dataIdAttr :: String
+    , ghostClass :: String
+    , chosenClass :: String
+    , dragClass :: String
+    , swapThreshold :: Int
+    , invertSwap :: Boolean
+    , invertedSwapThreshold :: Int
+    , direction :: String
+    , forceFallback :: Boolean
+    , fallbackClass :: String
+    , fallbackOnBody :: Boolean
+    , fallbackTolerance :: Int
+    , dragoverBubble :: Boolean
+    , removeCloneOnHide :: Boolean
+    , emptyInsertThreshold :: Number
+    {-- , setData :: DataTransfer -> HTMLElement -> Effect Unit --}
+    , onChoose :: Event -> Effect Unit
+    , onUnchoose :: Event -> Effect Unit
+    , onStart :: Event -> Effect Unit
+    , onEnd :: Event -> Effect Unit
+    , onAdd :: Event -> Effect Unit
+    , onUpdate :: Event -> Effect Unit
+    , onSort :: Event -> Effect Unit
+    , onRemove :: Event -> Effect Unit
+    , onFilter :: Event -> Effect Unit
+    , onMove :: MoveEvent -> Effect Unit
+    , onClone :: Event -> Effect Unit
+    , onChange :: Event -> Effect Unit
+    )
+
+foreign import create' ::
+  forall given.
+  Fn3
+    { | given }
+    HTMLElement
+    ((Event -> Effect Unit) -> (Foreign -> Effect Unit))
+    (Effect Sortable)
+
+parseEvent :: (Event -> Effect Unit) -> (Foreign -> Effect Unit)
+parseEvent f = wrappedF
+  where
+  wrappedF :: Foreign -> Effect Unit
+  wrappedF =
+    readEvent >>> runExcept
+      >>> ( case _ of
+            Left err -> throw $ formatErr err
+            Right event -> f event
+        )
+
+  formatErr :: NonEmptyList ForeignError -> String
+  formatErr err = intercalate ", " $ renderForeignError <$> err
+
+create ::
+  forall given trash.
+  Row.Union given trash Options =>
+  { | given } ->
+  HTMLElement ->
+  Effect Sortable
+create options elem = runFn3 create' options elem parseEvent