module PureTabs.Sidebar where
import Browser.Runtime as Runtime
import Browser.Tabs (Tab(..), TabId, WindowId)
import Browser.Tabs.OnUpdated (ChangeInfo(..))
import Browser.Windows (getCurrent)
import Control.Alternative (pure)
import Control.Bind ((>=>), (>>=))
import Data.CommutativeRing ((+))
import Data.Eq ((==))
import Data.Foldable (traverse_)
import Data.Function (flip)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid ((<>))
import Data.Show (show)
import Data.Unit (unit)
import Debug.Trace (traceM)
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Effect.Class (liftEffect)
import Effect.Console (log)
import JQuery as J
import JQuery.Ext (after, prepend) as J
import Prelude (Unit, bind, ($), discard)
import PureTabs.Model (BackgroundEvent(..), SidebarEvent(..))
main :: Effect Unit
main = do
log "started sidebar"
port <- Runtime.connect
launchAff_ $ runSidebar port
where
runSidebar :: Runtime.Port -> Aff Unit
runSidebar port = do
currentWindow <- getCurrent
liftEffect $ initSidebar port currentWindow.id
initSidebar :: Runtime.Port -> WindowId -> Effect Unit
initSidebar port winId = do
log $ "windowId " <> (show winId)
Runtime.postMessageJson port $ SbHasWindowId winId
_ <- Runtime.onMessageJsonAddListener port onMsg
pure unit
where
onMsg :: BackgroundEvent -> Effect Unit
onMsg event = case event of
BgTabCreated tab -> createTab port tab
BgTabDeleted tabId -> deleteTabElement tabId
BgInitialTabList tabs -> traverse_ (createTab port) tabs
BgTabUpdated tid cinfo tab -> updateTabInfo tid cinfo tab
BgTabActived prev new -> activateTab prev new
BgTabMoved tid prevPos newPos -> moveTab tid prevPos newPos
_ -> log "received unsupported message type"
createTab :: Runtime.Port -> Tab -> Effect Unit
createTab port (Tab tab) = do
tabsDiv <- J.select "#tabs"
tabElem <- createTabElement port (Tab tab)
insertTabAt tab.index tabElem
createTabElement :: Runtime.Port -> Tab -> Effect J.JQuery
createTabElement port (Tab tab) = do
tabDiv <- J.create "
"
J.setAttr "class" "tab" tabDiv
J.setAttr "id" tab.id tabDiv
J.on "click" onTabClick tabDiv
if tab.active then (J.addClass "active" tabDiv) else (pure unit)
if isDiscarded tab then (J.addClass "discarded" tabDiv) else (pure unit)
-- favicon
faviconDiv <- J.create "
"
J.addClass "tab-favicon" faviconDiv
setFaviconUrl tab.favIconUrl faviconDiv
J.append faviconDiv tabDiv
-- title
tabTitle <- J.create "
"
J.addClass "tab-title" tabTitle
J.setText tab.title tabTitle
J.append tabTitle tabDiv
-- close button
closeButton <- createCloseButton
J.append closeButton tabDiv
J.on "click" onCloseClick closeButton
pure tabDiv
where
onCloseClick :: J.JQueryEvent -> J.JQuery -> Effect Unit
onCloseClick event j = Runtime.postMessageJson port $ SbTabDeleted tab.id
onTabClick :: J.JQueryEvent -> J.JQuery -> Effect Unit
onTabClick event j = Runtime.postMessageJson port $ SbTabActived tab.id
isDiscarded :: forall r. { discarded :: Maybe Boolean | r } -> Boolean
isDiscarded { discarded: Just true } = true
isDiscarded _ = false
createCloseButton :: Effect J.JQuery
createCloseButton = do
parent <- J.create "
"
J.addClass "close-button-parent" parent
outer <- J.create "
"
J.addClass "close-button-outer" outer
J.append outer parent
inner <- J.create "
"
J.addClass "close-button-inner" inner
J.append inner outer
pure parent
setFaviconUrl :: Maybe String -> J.JQuery -> Effect Unit
setFaviconUrl Nothing div = pure unit
setFaviconUrl (Just favData) div = J.css { "background-image": favUrl } div
where
favUrl = "url(" <> favData <> ")"
deleteTabElement :: TabId -> Effect Unit
deleteTabElement tabId = do
div <- J.select ("#" <> show tabId)
J.remove div
updateTabInfo :: TabId -> ChangeInfo -> Tab -> Effect Unit
updateTabInfo tid (ChangeInfo cinfo) (Tab tab) = do
tabTitleDiv <- J.select ("#" <> (show tid) <> " > .tab-title")
let
newTitle = case cinfo.status of
Just "loading" -> Just "Loading ..."
_ -> Just tab.title
maybe (pure unit) (\t -> J.setText t tabTitleDiv) newTitle
maybe (pure unit) (\discarded -> J.setClass "discarded" discarded tabTitleDiv) tab.discarded
tabFaviconDiv <- J.select ("#" <> (show tid) <> " > .tab-favicon")
setFaviconUrl cinfo.favIconUrl tabFaviconDiv
activateTab :: (Maybe TabId) -> TabId -> Effect Unit
activateTab prev new = do
maybe (pure unit) (\p -> (J.select ("#" <> (show p))) >>= J.setClass "active" false) prev
newTab <- J.select ("#" <> (show new))
J.setClass "active" true newTab
moveTab :: TabId -> Int -> Int -> Effect Unit
moveTab tabId prev new = do
tabDiv <- J.select $ "#" <> show tabId
J.remove tabDiv
insertTabAt new tabDiv
insertTabAt :: Int -> J.JQuery -> Effect Unit
insertTabAt 0 tabDiv = do
allTabs <- J.select "#tabs"
J.prepend tabDiv allTabs
insertTabAt pos tabDiv = do
child <- J.select $ "#tabs > .tab:nth-child(" <> (show pos) <> ")"
J.after tabDiv child