ContextMenu.purs 4.26 KB
Newer Older
1
-- | The ContextMenu component renders a generic context menu
James Laver's avatar
James Laver committed
2
module Gargantext.Components.ContextMenu.ContextMenu where
3
  -- (MenuProps, Action(..), separator) where
4 5

import Prelude hiding (div)
6 7 8 9 10 11 12 13 14 15 16
import Data.Maybe ( Maybe(..) )
import Data.Nullable ( Nullable, null, toMaybe )
import Data.Tuple.Nested ( (/\) )
import Data.Traversable ( traverse_ )
import DOM.Simple as DOM
import DOM.Simple.Event as DE
import DOM.Simple.EventListener ( Callback, callback )
import DOM.Simple.Element as Element
import DOM.Simple.Window ( window )
import DOM.Simple.Document ( document )
import DOM.Simple.Types ( DOMRect )
17
import Effect (Effect)
18
import FFI.Simple ((..))
James Laver's avatar
James Laver committed
19
import Reactix as R
20
import Reactix.DOM.HTML as HTML
James Laver's avatar
James Laver committed
21

22
import Gargantext.Utils.Reactix as R2
James Laver's avatar
James Laver committed
23

24
type Props t = ( x :: Number, y :: Number, setMenu :: R2.Setter (Maybe t) )
James Laver's avatar
James Laver committed
25

26 27 28 29
contextMenu :: forall t. Record (Props t) -> Array R.Element -> R.Element
contextMenu = R.createElement contextMenuCpt

contextMenuCpt :: forall t. R.Component (Props t)
30
contextMenuCpt = R.hooksComponent "ContextMenu" cpt
James Laver's avatar
James Laver committed
31
  where
32
    cpt menu children = do
James Laver's avatar
James Laver committed
33
      host <- R2.getPortalHost
34
      root <- R.useRef null
James Laver's avatar
James Laver committed
35 36
      rect /\ setRect <- R.useState $ \_ -> Nothing
      R.useLayoutEffect1 (R.readRef root) $ do
37
        traverse_
James Laver's avatar
James Laver committed
38
          (\r -> setRect (\_ -> Just (Element.boundingRect r)))
39
          (toMaybe $ R.readRef root)
James Laver's avatar
James Laver committed
40
        pure $ pure unit
41
      R.useLayoutEffect2 root rect (contextMenuEffect menu.setMenu root)
42 43 44 45 46 47 48 49
      let cs = [
            HTML.div { className: "popover-content" }
            [ HTML.div { className: "panel panel-default" }
              [ HTML.ul { className: "list-group" }
                children
              ]
            ]
      ]
50
      pure $ R.createPortal [ elems root menu rect $ cs ] host
51 52 53 54 55 56 57 58 59 60 61
    elems ref menu (Just rect) = HTML.div
        { ref
        , className: "context-menu"
        , style: position menu rect
        , data: {toggle: "popover", placement: "right"}
        }
    elems ref _ _ = HTML.div
        { ref
        , className: "context-menu"
        , data: {toggle: "popover", placement: "right"}
        }
62 63 64

contextMenuEffect
  :: forall t
65
  .  R2.Setter (Maybe t)
66
  -> R.Ref (Nullable DOM.Element)
James Laver's avatar
James Laver committed
67 68
  -> Effect (Effect Unit)
contextMenuEffect setMenu rootRef =
69 70 71
  case R.readNullableRef rootRef of
    Just root -> do
      let onClick = documentClickHandler setMenu root
72 73 74
      let onScroll = documentScrollHandler setMenu
      DOM.addEventListener document "click" onClick
      DOM.addEventListener document "scroll" onScroll
James Laver's avatar
James Laver committed
75
      pure $ do
76 77
        DOM.removeEventListener document "click" onClick
        DOM.removeEventListener document "scroll" onScroll
James Laver's avatar
James Laver committed
78
    Nothing -> pure R.nothing
79

80
documentClickHandler :: forall t. R2.Setter (Maybe t) -> DOM.Element -> Callback DE.MouseEvent
81
documentClickHandler hide menu =
82
  R2.named "hideMenuOnClickOutside" $ callback $ \e ->
83 84
    if Element.contains menu (DE.target e)
      then pure unit
James Laver's avatar
James Laver committed
85
      else hide (const Nothing)
86

87
documentScrollHandler :: forall t. R2.Setter (Maybe t) -> Callback DE.MouseEvent
88
documentScrollHandler hide =
James Laver's avatar
James Laver committed
89
  R2.named "hideMenuOnScroll" $ callback $ \e -> hide (const Nothing)
90 91 92 93 94 95 96 97 98

position :: forall t. Record (Props t) -> DOMRect -> { left :: Number, top :: Number }
position mouse {width: menuWidth, height: menuHeight} = {left, top}
  where left = if isRight then mouse.x else mouse.x - menuWidth
        top = if isAbove then mouse.y else mouse.y - menuHeight
        isRight = screenWidth - mouse.x > menuWidth -- is there enough space to show above
        isAbove = screenHeight - mouse.y > menuHeight -- is there enough space to show to the right?
        screenWidth = window .. "innerWidth"
        screenHeight = window .. "innerHeight"
James Laver's avatar
James Laver committed
99 100

contextMenuItem :: Array R.Element -> R.Element
101
contextMenuItem = R.createElement contextMenuItemCpt {}
James Laver's avatar
James Laver committed
102

103 104
contextMenuItemCpt :: R.Component ()
contextMenuItemCpt = R.hooksComponent "ContextMenuItem" cpt
James Laver's avatar
James Laver committed
105
  where
106
    cpt _props children = pure $ HTML.li { className: "context-menu-item" } children
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123

-- -- CSS Classes

-- menuClass :: String
-- menuClass = "context-menu"

-- menuShownClass :: String
-- menuShownClass = "context-menu-shown"

-- menuHiddenClass :: String
-- menuHiddenClass = "context-menu-hidden"

-- itemClass :: String
-- itemClass = "context-menu-item"

-- separatorClass :: String
-- separatorClass = "context-menu-item"
124