feat: add Bar component

It will handle the groups of tab, showing the groups, a menu, switching
between groups, and forwarding the queries to the correct tab list.

packages.dhall

@@ -119,7 +119,7 @@ let additions =
 
 
 let upstream =
-      https://github.com/purescript/package-sets/releases/download/psc-0.13.8-20200724/packages.dhall sha256:bb941d30820a49345a0e88937094d2b9983d939c9fd3a46969b85ce44953d7d9
+      https://github.com/purescript/package-sets/releases/download/psc-0.13.8-20201021/packages.dhall sha256:55ebdbda1bd6ede4d5307fbc1ef19988c80271b4225d833c8d6fb9b6fb1aa6d8
 
 let overrides = {=}
 

spago.dhall

@@ -20,6 +20,7 @@ You can edit this file as you like.
   , "halogen-css"
   , "lists"
   , "numbers"
+  , "ordered-collections"
   , "profunctor"
   , "profunctor-lenses"
   , "psci-support"

src/Sidebar/Components/Bar.purs

@@ -0,0 +1,115 @@
+module PureTabs.Sidebar.Bar where
+
+import Browser.Tabs (Tab(..), TabId)
+import Control.Alternative (pure, (<$>))
+import Control.Bind (bind, discard, void, (<#>))
+import Data.Function (($))
+import Data.Map as M
+import Data.Maybe (Maybe(..))
+import Data.Symbol (SProxy(..))
+import Data.Tuple (Tuple(..), uncurry)
+import Data.Unit (Unit, unit)
+import Effect.Aff.Class (class MonadAff)
+import Effect.Class (class MonadEffect)
+import Halogen as H
+import Halogen.HTML as HH
+import Prelude (class Eq, class Ord, (<<<))
+import PureTabs.Model (SidebarEvent)
+import PureTabs.Sidebar.Tabs (Output(..))
+import PureTabs.Sidebar.Tabs as Tabs
+
+newtype GroupId
+  = GroupId Int
+
+derive instance eqGroupId :: Eq GroupId
+
+derive instance ordGroupId :: Ord GroupId
+
+type Group
+  = { name :: String
+    , pos :: Int
+    }
+
+type State
+  = { groups :: M.Map GroupId Group
+    , tabsToGroup :: M.Map TabId GroupId
+    , currentGroup :: GroupId
+    }
+
+data Action
+  = UserSelectedGroup GroupId
+  | HandleTabsOutput GroupId Tabs.Output
+
+initialState :: forall i. i -> State
+initialState _ =
+  let
+    firstGroupId = GroupId 0
+  in
+    { groups: M.singleton firstGroupId { name: "main", pos: 0 }, tabsToGroup: M.empty, currentGroup: firstGroupId }
+
+type Slots
+  = ( tabs :: H.Slot Tabs.Query Tabs.Output GroupId )
+
+_childLabel :: SProxy "tabs"
+_childLabel = (SProxy :: _ "tabs")
+
+component :: forall i m. MonadEffect m => MonadAff m => H.Component HH.HTML Tabs.Query i SidebarEvent m
+component =
+  H.mkComponent
+    { initialState
+    , render: render
+    , eval:
+        H.mkEval
+          $ H.defaultEval
+              { handleQuery = handleQuery
+              , handleAction = handleAction
+              }
+    }
+  where
+  render :: State -> H.ComponentHTML Action Slots m
+  render state = HH.div_ [
+    HH.div_ $ (uncurry renderTab) <$> (M.toUnfoldable state.groups)
+  ]
+
+  renderTab :: GroupId -> Group -> H.ComponentHTML Action Slots m
+  renderTab groupId group = HH.slot _childLabel groupId Tabs.component unit (Just <<< (HandleTabsOutput groupId))
+
+  handleAction :: Action -> H.HalogenM State Action Slots SidebarEvent m Unit
+  handleAction = case _ of
+    UserSelectedGroup gid -> pure unit
+    HandleTabsOutput gid event -> case event of
+      TabsSidebarAction sbEvent -> H.raise sbEvent
+
+  handleQuery :: forall act o a. Tabs.Query a -> H.HalogenM State act Slots o m (Maybe a)
+  handleQuery = case _ of
+    -- select the current group
+    -- associate all the tab id to the current group
+    -- send an action to the corresponding slot
+    Tabs.InitialTabList tabs a -> do
+       s <- H.modify (\s -> s { tabsToGroup = M.fromFoldable $ tabs <#> \(Tab t) -> Tuple t.id s.currentGroup })
+       void $ tellChild s.currentGroup $ Tabs.InitialTabList tabs
+       pure (Just a)
+    Tabs.TabCreated (Tab t) a -> do 
+       s <- H.modify (\s -> s { tabsToGroup = M.insert t.id s.currentGroup  s.tabsToGroup })
+       void $ tellChild s.currentGroup $ Tabs.TabCreated (Tab t)
+       pure (Just a)
+    Tabs.TabDeleted tid a -> do 
+       s <- H.modify (\s -> s { tabsToGroup = M.delete tid s.tabsToGroup })
+       void $ tellChild s.currentGroup $ Tabs.TabDeleted tid
+       pure (Just a)
+    Tabs.TabActivated oldTid tid a -> do 
+       s <- H.get
+       void $ tellChild s.currentGroup $ Tabs.TabActivated oldTid tid
+       pure (Just a)
+    Tabs.TabMoved tid prev next a -> do 
+       s <- H.get
+       void $ tellChild s.currentGroup $ Tabs.TabMoved tid prev next
+       pure (Just a)
+    Tabs.TabInfoChanged tid cinfo a -> do 
+       s <- H.get
+       void $ tellChild s.currentGroup $ Tabs.TabInfoChanged tid cinfo
+       pure (Just a)
+
+    where
+        tellChild :: GroupId -> (H.Tell Tabs.Query) -> H.HalogenM State act Slots o m (Maybe Unit)
+        tellChild gid q = H.query _childLabel gid $ H.tell q

src/Sidebar/Components/Tabs.purs

@@ -1,6 +1,5 @@
-module PureTabs.Sidebar.Tabs (component, Query(..)) where
+module PureTabs.Sidebar.Tabs (component, Query(..), Output(..)) where
 
-import Prelude (sub, negate)
 import Browser.Tabs (Tab(..), TabId)
 import Browser.Tabs.OnUpdated (ChangeInfo(..), ChangeInfoRec)
 import CSS.Background as CssBackground
@@ -10,7 +9,6 @@ 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.Eq ((==))
-import Data.Time.Duration (Milliseconds(..))
 import Data.Function (flip, ($))
 import Data.Lens (over)
 import Data.Maybe (Maybe(..), fromMaybe, maybe)
@@ -18,19 +16,24 @@ import Data.MediaType.Common (textPlain)
 import Data.Monoid ((<>))
 import Data.Show (show)
 import Data.Symbol (SProxy(..))
+import Data.Time.Duration (Milliseconds(..))
 import Data.Unit (Unit, unit)
 import Effect.AVar (AVar)
-import Effect.Aff.AVar (put, empty, take) as AVar
 import Effect.Aff (Aff, Fiber, forkAff, delay, killFiber)
+import Effect.Aff.AVar (put, empty, take) as AVar
 import Effect.Aff.Class (class MonadAff)
-import Effect.Exception (error)
 import Effect.Class (class MonadEffect)
 import Effect.Class.Console (log)
+import Effect.Exception (error)
 import Halogen as H
 import Halogen.HTML as HH
 import Halogen.HTML.CSS as CSS
 import Halogen.HTML.Events as HE
+import Halogen.HTML.Properties (class_)
+import Halogen.HTML.Properties (class_, classes)
+import Halogen.HTML.Properties (class_, classes)
 import Halogen.HTML.Properties as HP
+import Prelude (sub, negate)
 import PureTabs.Model (SidebarEvent(..), _tabs)
 import Web.Event.Event (Event)
 import Web.Event.Event as Event
@@ -46,6 +49,9 @@ data Query a
   | TabMoved TabId Int Int a
   | TabInfoChanged TabId ChangeInfo a
 
+data Output 
+  = TabsSidebarAction SidebarEvent
+
 data Action
   = UserClosedTab TabId Event
   | UserActivatedTab TabId Event
@@ -75,6 +81,7 @@ type Debouncer
     , timer :: Fiber Unit
     }
 
+
 type State
   = { tabs :: Array Tab
     , selectedElem :: Maybe DraggedTab
@@ -82,7 +89,7 @@ type State
     , leaveDebounce :: Maybe Debouncer
     }
 
-component :: forall i m. MonadEffect m => MonadAff m => H.Component HH.HTML Query i SidebarEvent m
+component :: forall i m. MonadEffect m => MonadAff m => H.Component HH.HTML Query i Output m
 component =
   H.mkComponent
     { initialState
@@ -147,16 +154,20 @@ render state =
     HH.div
       [ HP.id_ $ show t.id
       , HP.draggable true
+
       -- drag events
       , HE.onDragStart \evt -> Just $ TabDragStart evt (Tab t) index
       , HE.onDragEnd \evt -> Just $ TabDragEnd evt
       , HE.onDragOver \evt -> Just $ TabDragOver evt index
+
       -- fake hover to fix incorrect css hover effect during dragging
       , HE.onMouseEnter \evt -> Just $ TabMouseEnter evt index
       , HE.onMouseLeave \evt -> Just $ TabMouseLeave evt index
+
       -- click event
       , HE.onClick (\ev -> Just (UserActivatedTab t.id (ME.toEvent ev)))
       , HE.onDoubleClick (\ev -> Just (UserOpenedTab (Just t.id) (ME.toEvent ev)))
+
       -- classes
       , HP.classes $ H.ClassName
           <$> A.catMaybes
@@ -171,13 +182,16 @@ render state =
               ]
       , HP.title t.title
       ]
+
       [ HH.div [ HP.class_ $ H.ClassName "tab-favicon", faviconStyle t.favIconUrl ] []
+
       , HH.div [ HP.class_ $ H.ClassName "tab-title" ]
           [ HH.text
               $ case t.status of
                   Just "loading" -> "Loading ..."
                   _ -> t.title
           ]
+
       , HH.div
           [ HP.class_ $ H.ClassName "close-button-parent"
           , HE.onClick (\ev -> Just (UserClosedTab t.id (ME.toEvent ev)))
@@ -200,14 +214,14 @@ render state =
 
   isDiscarded _ = false
 
-cancelLeaveDebounce :: forall m. MonadAff m => State -> H.HalogenM State Action () SidebarEvent m Unit
+cancelLeaveDebounce :: forall m. MonadAff m => State -> H.HalogenM State Action () Output m Unit
 cancelLeaveDebounce state = case state.leaveDebounce of
   Just { var, timer } -> do
     H.liftAff $ killFiber (error "could not cancel timer") timer
     H.modify_ _ { leaveDebounce = Nothing }
   Nothing -> pure unit
 
-runDebounce :: forall m. MonadAff m => Action -> H.HalogenM State Action () SidebarEvent m Unit
+runDebounce :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
 runDebounce actionToRun = do
   state <- H.get
   let
@@ -224,6 +238,7 @@ runDebounce actionToRun = do
       let
         debouncer = { var, timer }
       H.modify_ _ { leaveDebounce = Just debouncer }
+
     Just { var, timer } -> do
       H.liftAff $ killFiber (error "could not cancel timer") timer
       nextTimer <- H.liftAff (debounceTimeout debounceTime var)
@@ -231,29 +246,33 @@ runDebounce actionToRun = do
         debouncer = { var, timer: nextTimer }
       H.modify_ _ { leaveDebounce = Just debouncer }
 
-handleAction :: forall m. MonadEffect m => MonadAff m => Action -> H.HalogenM State Action () SidebarEvent m Unit
+handleAction :: forall m. MonadEffect m => MonadAff m => Action -> H.HalogenM State Action () Output m Unit
 handleAction = case _ of
+
   UserClosedTab tid ev -> do
     H.liftEffect
       $ do
           Event.preventDefault ev
           Event.stopPropagation ev
           log "sb: closed a tab"
-    H.raise $ SbDeleteTab tid
+    H.raise $ TabsSidebarAction $ SbDeleteTab tid
+
   UserActivatedTab tid ev -> do
     H.liftEffect
       $ do
           Event.preventDefault ev
           Event.stopPropagation ev
           log "sb: activated a tab"
-    H.raise $ SbActivateTab tid
+    H.raise $ TabsSidebarAction $ SbActivateTab tid
+
   UserOpenedTab tid ev -> do
     H.liftEffect
       $ do
           Event.preventDefault ev
           Event.stopPropagation ev
           log "sb: created a tab"
-    H.raise $ SbCreateTab tid
+    H.raise $ TabsSidebarAction $ SbCreateTab tid
+
   -- Drag actions
   TabDragStart dragEvent tab index -> do
     let
@@ -264,6 +283,7 @@ handleAction = case _ of
           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)
+
   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
@@ -282,9 +302,11 @@ handleAction = case _ of
           | overIndex' == index -> pure unit
         _ -> H.modify_ (_ { selectedElem = Just $ selectedRec { overIndex = Just index } })
       Nothing -> pure unit
+
   PreventPropagation event -> do
     H.liftEffect $ Event.stopImmediatePropagation event
     pure unit
+
   TabDragEnd event -> do
     state <- H.get
     cancelLeaveDebounce state
@@ -292,21 +314,25 @@ handleAction = case _ 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 (SbMoveTab t.id overIndex)
+      Just { tab: (Tab t), originalIndex, overIndex: (Just overIndex) } -> H.raise $ TabsSidebarAction (SbMoveTab t.id overIndex)
       Just { overIndex: Nothing } -> H.modify_ _ { selectedElem = 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
+
   -- Mouse over action
   TabMouseEnter evt index -> do
     state <- H.get
     case state of
       { tabHovered: Nothing, selectedElem: Nothing } -> H.modify_ _ { tabHovered = Just index }
       _ -> pure unit
+
   TabMouseLeave evt index -> do
     state <- H.get
     case state.tabHovered of
@@ -315,17 +341,21 @@ handleAction = case _ of
 
 handleQuery :: forall act o m a. Query a -> H.HalogenM State act () o m (Maybe a)
 handleQuery = case _ of
+
   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)
       *> pure (Just a)
+
   TabDeleted tid a ->
     H.modify_
       ( over _tabs
           $ applyAtTabId tid A.deleteAt
       )
       *> pure (Just a)
+
   TabActivated oldTid tid a ->
     H.modify_
       ( over _tabs
@@ -333,6 +363,7 @@ handleQuery = case _ of
           >>> applyAtTabId tid (setTabActiveAtIndex true)
       )
       *> pure (Just a)
+
   TabMoved tid prev next a -> do
     state <- H.get
     let
@@ -348,6 +379,7 @@ handleQuery = case _ of
       -- state.
       H.modify_ \s -> s { selectedElem = Nothing }
     pure (Just a)
+
   TabInfoChanged tid cinfo a ->
     H.modify_
       ( over _tabs

src/Sidebar/Sidebar.purs

@@ -19,6 +19,7 @@ import Halogen.Aff as HA
 import Halogen.VDom.Driver (runUI)
 import Prelude (bind, discard)
 import PureTabs.Model (BackgroundEvent(..), SidebarEvent(..))
+import PureTabs.Sidebar.Bar as Bar
 import PureTabs.Sidebar.Tabs as Tabs
 import Web.DOM.ParentNode (QuerySelector(..))
 
@@ -31,7 +32,7 @@ main = do
     content' <- HA.selectElement (QuerySelector "#content")
     io <- case content' of
       Nothing -> throwError (error "Could not find #content")
-      Just content -> runUI Tabs.component unit content
+      Just content -> runUI Bar.component unit content
     io.subscribe $ onSidebarMsg port
     CR.runProcess ((onBackgroundMsgProducer port) CR.$$ onBackgroundMsgConsumer io.query)
 
@@ -66,6 +67,6 @@ onBackgroundMsgConsumer query =
 
 onSidebarMsg :: Runtime.Port -> CR.Consumer SidebarEvent Aff Unit
 onSidebarMsg port =
-  CR.consumer \msg -> do
+  CR.consumer \(msg) -> do
     liftEffect $ Runtime.postMessageJson port msg
     pure Nothing