purescript_web_ext/src/Sidebar/Components/Bar.purs

module PureTabs.Sidebar.Bar where

import Browser.Tabs (Tab(..), TabId)
import Browser.Utils (eqBy, sortByKeyIndex, unsafeLog)
import Control.Bind (bind, discard, map, void, (<#>), (=<<), (>>=))
import Data.Array ((:))
import Data.Array as A
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NonEmptyArray
import Data.Eq ((/=))
import Data.Foldable (for_)
import Data.Function (($))
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe, fromMaybe', maybe)
import Data.MediaType.Common (textPlain)
import Data.Number (fromString)
import Data.Set (Set, toUnfoldable) as S
import Data.Set.NonEmpty (cons, max) as NES
import Data.Symbol (SProxy(..))
import Data.Traversable (sequence, traverse)
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, liftEffect)
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 (flip, join, pure, show, (#), (&&), (+), (-), (<$>), (<<<), (<>), (==), (>), (>>>))
import PureTabs.Model.Group (GroupId(..))
import PureTabs.Model.GroupMapping (GroupData(..))
import PureTabs.Model.SidebarEvent (SidebarEvent(..))
import PureTabs.Model.TabWithGroup (TabWithGroup(..))
import PureTabs.Sidebar.Component.GroupName as GroupName
import PureTabs.Sidebar.Component.TopMenu as TopMenu
import PureTabs.Sidebar.Tabs (Output(..))
import PureTabs.Sidebar.Tabs as Tabs
import PureTabs.Utils (ifU)
import Sidebar.Utils (moveElem, whenC)
import Web.HTML.Event.DataTransfer as DT
import Web.HTML.Event.DragEvent as DE


-- TODO: correctly use `pos` when adding or deleting a group (i.e. making sure
-- the pos are contiguous from 0 to #groups - 1)
type Group
  = { name :: String
    , pos :: Int
    }

type State
  = { groups :: M.Map GroupId Group
    , tabsToGroup :: M.Map TabId GroupId
    , groupTabsPositions :: Array (Tuple TabId GroupId)
    , currentGroup :: GroupId
    , draggedCurrentGroup :: Maybe GroupId
    }

data Action
  = UserSelectedGroup GroupId
  | UserRenameGroup GroupId String
  | UserCreatedGroup
  | UserChangedDeletion Boolean
  | UserDeletedGroup GroupId
  | HandleTabsOutput GroupId Tabs.Output
  | GroupNameDragOver DE.DragEvent GroupId
  | DragEnd DE.DragEvent


data Query a
  = TabsQuery (Tabs.Query a)
  | InitialTabsWithGroup (Array GroupData) (Array TabWithGroup) a
  | InitializeGroups (Array GroupData) a
  | AssignTabToGroup TabId (Maybe GroupId) a
  | GroupDeleted GroupId (Maybe TabId) a

initialGroup :: M.Map GroupId Group
initialGroup = M.fromFoldable [ Tuple (GroupId 0) { name: "main", pos: 0 } ]

initialState :: forall i. i -> State
initialState _ =
  { groups: initialGroup
    , tabsToGroup: M.empty
    , groupTabsPositions : []
    , currentGroup: GroupId 0
    , draggedCurrentGroup: Nothing
    }

type Slots
  = ( tabs :: Tabs.Slot GroupId
    , groupName :: GroupName.Slot GroupId
    , topMenu :: TopMenu.Slot Unit)

_tabs :: SProxy "tabs"
_tabs = (SProxy :: _ "tabs")

_groupName :: SProxy "groupName"
_groupName = (SProxy :: _ "groupName")

_topMenu :: SProxy "topMenu"
_topMenu = (SProxy :: _ "topMenu")

component :: forall i m. MonadEffect m => MonadAff m => H.Component HH.HTML 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 = 
    let 
        currentGroupShown = fromMaybe state.currentGroup state.draggedCurrentGroup

        topMenu = HH.slot _topMenu unit TopMenu.component unit (
          Just <<< case _ of 
               TopMenu.CreateGroup -> UserCreatedGroup
               TopMenu.ChangedDeletion value -> UserChangedDeletion value
        )

        -- TODO: order groups by `pos`
        barListGroup = HH.div [ HP.id_ "bar-list" ] [HH.ul [ HP.id_ "bar-list-group"] $ 
          (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 == currentGroupShown) (H.ClassName "bar-tabs-active")] 
          ] [renderGroupTabs gid])
    
     in
        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 _tabs groupId Tabs.component unit (Just <<< (HandleTabsOutput groupId))

  renderGroup :: GroupId -> Boolean -> Group -> H.ComponentHTML Action Slots m
  renderGroup groupId isActive group =  
    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 
          case _ of 
               GroupName.NewName newName -> Just (UserRenameGroup groupId newName)
               GroupName.DeleteGroup -> Just (UserDeletedGroup groupId)
    ] 

handleAction :: forall m. MonadEffect m => Action -> H.HalogenM State Action Slots SidebarEvent m Unit
handleAction = 
  case _ of

       UserSelectedGroup gid -> do
          H.modify_ _ { currentGroup = gid }

       UserRenameGroup gid newName -> do
          H.modify_ \s -> s { groups = M.update (\g -> Just $ g { name = newName }) gid s.groups }
          H.raise $ SbRenamedGroup gid newName

       UserCreatedGroup -> do
          s <- H.get
          let Tuple gid newGroup = createGroup Nothing s
          H.modify_ $ insertGroup gid newGroup
          H.raise $ SbCreatedGroup gid newGroup.name

       UserChangedDeletion value -> void $ H.queryAll _groupName $ H.tell $ GroupName.DeletionEnabled value

       UserDeletedGroup gid -> do 
          s <- H.get
          if M.size s.groups > 1 then
            H.raise $ SbDeletedGroup gid $ getTabIdsOfGroup gid s.tabsToGroup
          else 
            void $ H.query _groupName gid $ H.tell $ GroupName.TriedToDeleteLastGroup

       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
                 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
        moveTabToGroup 
          :: MonadEffect m => TabId 
          -> GroupId 
          -> GroupId 
          -> State 
          -> H.HalogenM State Action Slots SidebarEvent m Unit
        moveTabToGroup _ fromGroup toGroup _ | fromGroup == toGroup = pure 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

              -- The new index of tab in the group will be at the end.
              newIndexInGroup = state.groupTabsPositions #
                                    A.length <<<
                                    A.filter (T.snd >>> (==) toGroup)

          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
            }

          deletedTab' <- H.query _tabs fromGroup $ H.request $ Tabs.TabDeleted tid
          case deletedTab' of 
               Just (Just (Tab tab)) -> 
                 void $ H.query _tabs toGroup $ H.tell 
                  $ Tabs.TabCreated $ Tab (tab { index = newIndexInGroup })
               _ -> pure unit

          H.raise $ SbMoveTab tid newTabIndex
          H.raise $ SbActivateTab tid
          H.raise $ SbChangeTabGroup tid (Just toGroup)
          void $ handleTabsQuery $ Tabs.TabActivated (Just tid) tid Nothing

        -- | Raise a SbMoveTab event with the tab index corrected from the point of view of the
        -- | group to that of the Firefox window.
        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 a m. MonadEffect m => Query a -> H.HalogenM State Action Slots SidebarEvent m (Maybe a)
handleQuery = case _ of 
   TabsQuery q -> handleTabsQuery q

   InitializeGroups groups a -> do
      liftEffect $ log $ "[sb] initializing groups"
      let newGroups = M.fromFoldable $ 
            A.mapWithIndex (\idx (GroupData g) -> Tuple g.groupId { name: g.name, pos: idx}) groups

      -- TODO: re-assign existing tabs to the new groups.
      H.modify_ \s ->
        if newGroups == s.groups then
          s
        else
          s { groups = newGroups }

      pure (Just a)

   -- Given Nothing, we assign the group ourselves (i.e. the tab had no group to start with)
   AssignTabToGroup tid Nothing a -> do 
      { tabsToGroup } <- H.get
      let groupId = M.lookup tid tabsToGroup
      for_ groupId \gid -> H.raise $ SbChangeTabGroup tid (Just gid)
      pure (Just a)

   -- Given an existing group for the tab, we modify our state to reflect it. No need to update the
   -- background since the information already comes for there.
   AssignTabToGroup tid (Just gid) a -> do 
      oldS <- H.get

      for_ (M.lookup tid oldS.tabsToGroup) \prevGid -> do
        liftEffect $ log $ "[sb] assigning " <> (show tid) <> " to " <> (show gid) <> " from " <> (show prevGid)
        s <- H.modify \s ->
          let newGroupTabsPositions = 
                s.groupTabsPositions <#> \tup@(Tuple tid' gid') -> if tid == tid' then Tuple tid gid else tup
          in
             s { tabsToGroup = M.insert tid gid s.tabsToGroup, groupTabsPositions = newGroupTabsPositions }

        tab <- join <$> (H.query _tabs prevGid $ H.request $ Tabs.TabDeleted tid)

        let newTabIndex = getGroupPositionOfTab tid gid s.groupTabsPositions

        case Tuple tab newTabIndex of
             Tuple (Just (Tab tab')) (Just newTabIndex') -> 
               void $ H.query _tabs gid $ H.tell $ Tabs.TabCreated (Tab $ tab' { index = newTabIndex'})
             _ -> liftEffect $ log $ "[sb] couldn't find the tab or the position of the tab"

      pure (Just a)

   InitialTabsWithGroup groups tabs a -> do
       -- Assign the tabs to their group and save the tabs positions
       s <- H.modify \s ->
         let 
             newGroups = 
               case groups of
                    [] -> initialGroup
                    newGroups' -> 
                      M.fromFoldable $ 
                        A.mapWithIndex 
                        (\idx (GroupData g) -> Tuple g.groupId { name: g.name, pos: idx})
                        newGroups'

             existingGroups = M.keys newGroups

             tabIdGroup = tabs <#> \(TabWithGroup (Tab t) gid) -> Tuple t.id gid
          in
             s { groups = newGroups, tabsToGroup = M.fromFoldable tabIdGroup, groupTabsPositions = tabIdGroup }

       -- Initialize each child tabs component with its tabs
       let 
            tabsGroups = tabs <#> \(TabWithGroup tab@(Tab t) _) -> Tuple tab $ fromMaybe s.currentGroup (M.lookup t.id s.tabsToGroup)
            groupedTabs = A.groupBy (eqBy T.snd) (sortByKeyIndex T.snd tabsGroups)
       void $ traverse initializeGroup groupedTabs

       -- Activate the right tab and its group
       let activatedTab = tabsGroups # A.head <<< A.filter (\(Tuple (Tab t) _) -> t.active)
       activatedTab # maybe (pure unit) \(Tuple (Tab t) gid) -> do
         void $ tellChild gid $ Tabs.TabActivated Nothing t.id
         handleAction $ UserSelectedGroup gid

       pure (Just a)

      where 
            initializeGroup :: forall act. NonEmptyArray (Tuple Tab GroupId) -> H.HalogenM State act Slots SidebarEvent m Unit
            initializeGroup groupedTabs = 
              let 
                  gid = T.snd $ NonEmptyArray.head groupedTabs
              in 
                  void $ tellChild gid $ Tabs.InitialTabList $ A.fromFoldable $ T.fst <$> groupedTabs

   GroupDeleted gid currentTid a -> do 
      H.modify_ \s -> 
        let 
            currentGroup = fromMaybe s.currentGroup $ currentTid >>= (flip M.lookup s.tabsToGroup)
         in
            s { groups = M.delete gid s.groups, currentGroup = currentGroup }
      pure $ Just a


handleTabsQuery :: forall act a m. MonadEffect m => Tabs.Query a -> H.HalogenM State act Slots SidebarEvent m (Maybe a)
handleTabsQuery = case _ of

    Tabs.InitialTabList tabs a -> pure $ Just a

    Tabs.TabCreated (Tab tab) a -> do 
       s <- H.get

       let tabGroupId = fromMaybe s.currentGroup $ tab.openerTabId >>= (flip M.lookup) s.tabsToGroup

           newGroupTabsPositions = 
             fromMaybe s.groupTabsPositions 
             $ A.insertAt tab.index (Tuple tab.id tabGroupId) s.groupTabsPositions

           inGroupPosition = getPositionTabInGroup tab.index tabGroupId newGroupTabsPositions 

           newTab = Tab $ tab { index = inGroupPosition }

       newS <- H.modify \state -> 
         state 
         { tabsToGroup = M.insert tab.id tabGroupId s.tabsToGroup 
         , groupTabsPositions = newGroupTabsPositions
         , currentGroup = tabGroupId
         }

       void $ tellChild tabGroupId $ Tabs.TabCreated newTab
       pure $ Just a

    Tabs.TabDeleted tid reply -> do 
       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 $ H.query _tabs gid $ H.request $ Tabs.TabDeleted tid
       pure (Just (reply Nothing))

    Tabs.TabActivated prevTid' tid a -> do 
       for_ prevTid' \prevTid ->
         doOnTabGroup prevTid \gid -> 
           void $ tellChild gid $ Tabs.TabActivated prevTid' tid

       doOnTabGroup tid \gid -> do 
         { tabsToGroup } <- H.modify (_ { currentGroup = gid})
         H.raise $ SbSelectedGroup $ getTabIdsOfGroup gid tabsToGroup
         void $ tellChild gid $ Tabs.TabActivated prevTid' tid
       pure (Just a)

    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 \gid -> do
         void $ tellChild gid $ Tabs.TabInfoChanged tid cinfo
       pure (Just a)

    Tabs.TabDetached tid a -> do 
       handleTabsQuery $ Tabs.TabDeleted tid \_ -> a

    Tabs.TabAttached tab a -> do 
       handleTabsQuery $ Tabs.TabCreated tab a

doOnTabGroup 
  :: forall m act
   . TabId 
  -> (GroupId -> H.HalogenM State act Slots SidebarEvent m Unit) 
  -> H.HalogenM State act Slots SidebarEvent m Unit
doOnTabGroup tabId f = do
  { tabsToGroup } <- H.get
  case M.lookup tabId tabsToGroup of 
       Just groupId -> f groupId
       Nothing -> pure unit



tellChild :: forall act m. GroupId -> (H.Tell Tabs.Query) -> H.HalogenM State act Slots SidebarEvent m (Maybe Unit)
tellChild gid q = H.query _tabs gid $ H.tell q

-- | Get the group position of the tab at the given index in the given group.
-- | Return 0 if the tab doesn't exist (same as if the tab when in the first
-- | position).
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)

-- | Get the window position of a tab.
getPositionTab 
  :: TabId
  -> GroupId
  -> Array (Tuple TabId GroupId)
  -> Maybe Int
getPositionTab tid gid arr = A.findIndex (\(Tuple tid' gid') -> tid' == tid && gid' == gid) arr

-- | Get the tab IDs of a group.
getTabIdsOfGroup 
  :: GroupId
  -> M.Map TabId GroupId
  -> Array TabId
getTabIdsOfGroup gid =
  M.toUnfoldable 
  >>> A.filter (\(Tuple tid gid') -> gid' == gid)
  >>> map T.fst

getGroupPositionOfTab
  :: TabId
  -> GroupId
  -> Array (Tuple TabId GroupId)
  -> Maybe Int
getGroupPositionOfTab tid gid = 
  A.filter (T.snd >>> (==) gid) 
  >>> A.findIndex (T.fst >>> (==) tid)


-- | 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.last
    >>> map ((+) 1)

findNextGroupId :: S.Set GroupId -> GroupId
findNextGroupId values = 
  let GroupId(maxValue) = NES.max (NES.cons (GroupId 0) values)
   in GroupId(maxValue + 1)

createGroup :: (Maybe GroupId) -> State -> Tuple GroupId Group
createGroup mGid s =
  let 
      gid = fromMaybe' (\_ -> findNextGroupId $ M.keys s.groups) mGid
  in
    Tuple gid { name: "new group", pos: M.size s.groups }

insertGroup :: GroupId -> Group -> State -> State
insertGroup gid group s = s { groups = M.insert gid group s.groups }