Fix ContextMenu and integrate into AnnotatedField

src/Gargantext/Components/Annotation/AnnotatedField.purs

@@ -13,23 +13,26 @@ module Gargantext.Components.Annotation.AnnotatedField where
 
 import Prelude
 import Data.Map as Map
-import Data.Maybe ( Maybe(..), maybe )
+import Data.Maybe ( Maybe(..), maybe, maybe' )
 import Data.Lens ( Lens', lens )
 import Data.Traversable ( traverse_ )
 import Data.Tuple ( Tuple(..) )
+import Data.Tuple.Nested ( (/\) )
+import DOM.Simple.Console
+import DOM.Simple.Event as DE
 import Effect ( Effect )
+import Effect.Uncurried (mkEffectFn1)
 import Reactix as R
-import Reactix.DOM.Raw as RDOM
+import Reactix.DOM.HTML as HTML
 import Reactix.SyntheticEvent as E
 
 import Gargantext.Types ( TermList(..) )
 import Gargantext.Components.Annotation.Utils ( termClass )
 import Gargantext.Components.NgramsTable ( NgramsTable(..), highlightNgrams )
-import Gargantext.Components.Annotation.Menu ( annotationMenu )
+import Gargantext.Components.ContextMenu.ContextMenu as CM
+import Gargantext.Components.Annotation.Menu ( AnnotationMenu, annotationMenu )
 import Gargantext.Utils.Selection as Sel
 
-newtype PageOffset = PageOffset { x :: Number, y :: Number }
-
 type Run = Tuple String (Maybe TermList)
 
 type Props = ( ngrams :: NgramsTable, text :: Maybe String )
@@ -41,13 +44,53 @@ annotatedField :: Record Props -> R.Element
 annotatedField p = R.createElement annotatedFieldComponent p []
 
 annotatedFieldComponent :: R.Component Props
-annotatedFieldComponent = R.staticComponent "AnnotatedField" cpt
+annotatedFieldComponent = R.hooksComponent "AnnotatedField" cpt
   where
-    runs props = annotateRun <$> compile props
-    cpt props _ =
-      RDOM.div { className: "annotated-field-wrapper" }
-        [ annotationMenu { termList: Nothing }
-        , RDOM.div { className: "annotated-field-runs" } (annotateRun <$> compile props) ]
+    runs props =
+      HTML.div { className: "annotated-field-runs" } $
+        annotateRun <$> compile props
+    cpt props _ = do
+      menu /\ setMenu <- R.useState $ \_ -> pure Nothing
+      let wrapperProps =
+            { className: "annotated-field-wrapper"
+            , onContextMenu: mkEffectFn1 (maybeShowMenu setMenu props.ngrams) }
+      pure $ HTML.div wrapperProps [ maybeAddMenu setMenu (runs props) menu]
+
+maybeAddMenu
+  :: (Maybe AnnotationMenu -> Effect Unit)
+  -> R.Element
+  -> Maybe AnnotationMenu
+  -> R.Element
+maybeAddMenu setMenu e (Just props) = annotationMenu setMenu props <> e
+maybeAddMenu _ e _ = e
+
+compile :: Record Props -> Array Run
+compile props = runs props.text
+  where runs = maybe [] (highlightNgrams props.ngrams)
+
+maybeShowMenu
+  :: forall t
+  .  (Maybe AnnotationMenu -> Effect Unit)
+  -> NgramsTable
+  -> E.SyntheticEvent DE.MouseEvent
+  -> Effect Unit
+maybeShowMenu setMenu ngrams event = do
+  s <- Sel.getSelection
+  case s of
+    Just sel -> do
+      case Sel.toString sel of
+        "" -> pure unit
+        sel' -> do
+          let x = E.clientX event
+          let y = E.clientY event
+          E.preventDefault event
+          setMenu $ Just { x, y, list: findNgram ngrams sel' }
+    Nothing -> pure unit
+
+findNgram :: NgramsTable -> String -> Maybe TermList
+findNgram _ _ = Nothing
+
+-- Runs
 
 type RunProps = ( list :: Maybe TermList, text :: String )
 
@@ -56,40 +99,9 @@ annotateRun (Tuple text list) = R.createElement annotatedRunComponent { text, li
 
 annotatedRunComponent :: R.Component RunProps
 annotatedRunComponent = R.staticComponent "AnnotatedRun" cpt
-  where cpt { text, list } _ = maybe (unstyled text) (styled text) list
-        styled text list = RDOM.span { className: className list } [ RDOM.text text ]
-        unstyled text = RDOM.span {} [ RDOM.text text ]
+  where cpt { text, list } _ = maybe' (\_ -> unstyled text) (styled text) list
+        styled text list = HTML.span { className: className list } [ HTML.text text ]
+        unstyled text = HTML.span {} [ HTML.text text ]
         className list = "annotation-run " <> termClass list
 
-compile :: Record Props -> Array Run
-compile props = runs props.text
-  where runs (Just text) = highlightNgrams props.ngrams text
-        runs _ = []
-
-maybeShowMenu :: E.MouseEvent -> NgramsTable -> (Maybe TermList -> Effect Unit) -> Effect Unit
-maybeShowMenu e n a = Sel.getSelection >>= traverse_ (a <<< findNgram n <<< Sel.toString)
-
--- showMenu
-
-
-findNgram :: NgramsTable -> String -> Maybe TermList
-findNgram _ _ = Nothing
-
--- contextMenuHandler :: (Action -> Effect Unit) -> MouseEvent -> Effect Unit
--- contextMenuHandler d e =
---   do sel <- getSelection
---      case toString <$> sel of
---        Just s -> submit s
---        Nothing -> pure unit
---   where submit s = offset >>= \o -> d $ OnContextMenu o s
---         offset =
---           do x <- pageX e
---              y <- pageY e
---              pure $ PageOffset { x, y }
-
-
--- _runs :: Lens' State (Array Run)
--- _runs = lens (\a -> a.runs) (\a r -> a { runs = r })
 
--- _contextMenu :: Lens' State ???
--- _contextMenu = lens (\a -> a.contextMenu) (\a m -> a { contextMenu = m })

src/Gargantext/Components/Annotation/Menu.purs

@@ -4,40 +4,41 @@ module Gargantext.Components.Annotation.Menu where
 
 import Prelude ( Unit, (==), ($), (<>), unit, pure )
 import Data.Array as A
-import Data.Maybe ( Maybe(..) )
+import Data.Maybe ( Maybe(..), maybe' )
 import Effect ( Effect )
 import Effect.Uncurried ( mkEffectFn1 )
 import Reactix as R
-import Reactix.DOM.Raw as RDOM
-import Unsafe.Coerce ( unsafeCoerce )
+import Reactix.DOM.HTML as HTML
+import Reactix.SyntheticEvent as E
 
 import Gargantext.Types ( TermList(..), termListName )
-import Gargantext.Utils.Reactix as R'
 import Gargantext.Components.Annotation.Utils ( termClass )
 
 import Gargantext.Components.ContextMenu.ContextMenu as CM
 
-type Props = ( termList :: Maybe TermList )
+type Props = ( list :: Maybe TermList )
+
+type AnnotationMenu = { x :: Number, y :: Number, list :: Maybe TermList }
 
 -- | An Annotation Menu is parameterised by a Maybe Termlist of the
 -- | TermList the currently selected text belongs to
-annotationMenu :: Record Props -> R.Element
-annotationMenu p = R.createElement annotationMenuCpt p []
+annotationMenu :: (Maybe AnnotationMenu -> Effect Unit) -> AnnotationMenu -> R.Element
+annotationMenu setMenu { x,y,list } =
+  CM.contextMenu { x,y,setMenu } [ R.createElement annotationMenuCpt {list} [] ]
 
 annotationMenuCpt :: R.Component Props
 annotationMenuCpt = R.hooksComponent "Annotation.Menu" cpt
   where
-    cpt { termList } _ = pure $
-      RDOM.div { className: "annotation-menu" } [ CM.contextMenu $ children termList ]
+    cpt { list } _ = pure $ R.fragment $ children list
     children l = A.mapMaybe (\l' -> addToList l' l) [ GraphTerm, CandidateTerm, StopTerm ]
 
--- | Given the TermList to render the item for and the Maybe TermList the item may belong to, possibly render the menuItem
+-- | Given the TermList to render the item for zand the Maybe TermList the item may belong to, possibly render the menuItem
 addToList :: TermList -> Maybe TermList -> Maybe R.Element
 addToList t (Just t')
   | t == t' = Nothing
   | true = addToList t Nothing
 addToList t _ = Just $ CM.contextMenuItem [ link ]
-  where link = R'.a { onClick: click, className: className } [ RDOM.text label ]
+  where link = HTML.a { onClick: click, className: className } [ HTML.text label ]
         label = "Add to " <> termListName t
         className = termClass t
         click = mkEffectFn1 $ \_ -> addToTermList t

src/Gargantext/Components/ContextMenu/ContextMenu.purs

@@ -3,21 +3,91 @@ module Gargantext.Components.ContextMenu.ContextMenu where
   -- (MenuProps, Action(..), separator) where
 
 import Prelude hiding (div)
+import Data.Maybe ( Maybe(..) )
+import Data.Nullable ( Nullable, null, toMaybe )
+import Data.Tuple ( Tuple(..) )
+import Data.Tuple.Nested ( (/\) )
+import Data.Traversable ( traverse_ )
+import DOM.Simple as DOM
+import DOM.Simple.Console
+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.Document as Document
+import DOM.Simple.Types ( DOMRect )
 import Effect (Effect)
+import Effect.Uncurried ( mkEffectFn1 )
+import FFI.Simple ( (...), (..), delay )
 import Reactix as R
-import Reactix.DOM.Raw as RDOM
+import Reactix.DOM.HTML as HTML
+import Reactix.SyntheticEvent as E
 
 import Gargantext.Utils.Reactix as R'
 
-contextMenu :: Array R.Element -> R.Element
-contextMenu = R.createElement contextMenuCpt {}
+type Props t = ( x :: Number, y :: Number, setMenu :: Maybe t -> Effect Unit)
 
-contextMenuCpt :: R.Component ()
+getPortalHost :: R.Hooks DOM.Element
+getPortalHost = R.unsafeHooksEffect $ delay unit $ \_ -> pure $ document ... "getElementById" $ ["menu-portal"]
+
+contextMenu :: forall t. Record (Props t) -> Array R.Element -> R.Element
+contextMenu = R.createElement contextMenuCpt
+
+contextMenuCpt :: forall t. R.Component (Props t)
 contextMenuCpt = R.hooksComponent "ContextMenu" cpt
   where
-    cpt _props children = pure $
-      R'.nav { className: "context-menu" }
-        [ R'.ul { className: "context-menu-items" } children ]
+    cpt menu children = do
+      host <- getPortalHost
+      root <- R.useRef null
+      rect /\ setRect <- R.useState $ \_ -> pure Nothing
+      R.useLayoutEffect1 (R.readRef root) $ \_ -> do
+        traverse_
+          (\r -> setRect $ Just (Element.boundingRect r))
+          (toMaybe $ R.readRef root)
+        pure $ \_ -> pure unit
+      R.useLayoutEffect2 root rect (contextMenuEffect menu.setMenu root)
+      let cs = [ HTML.ul { className: "context-menu-items" } children ]
+      pure $ R.createPortal [ elems root menu rect $ cs ] host
+    elems ref menu (Just rect) = HTML.nav { ref , className: "context-menu", style: position menu rect}
+    elems ref _ _ = HTML.nav { ref, className: "context-menu" }
+
+contextMenuEffect
+  :: forall t
+  .  (Maybe t -> Effect Unit)
+  -> R.Ref (Nullable DOM.Element)
+  -> Unit -> Effect (Unit -> Effect Unit)
+contextMenuEffect setMenu ref _ =
+  case toMaybe $ R.readRef ref of
+    Just elem -> do
+      let onClick = documentClickHandler setMenu elem
+      let onScroll = documentScrollHandler setMenu
+      DOM.addEventListener document "click" onClick
+      DOM.addEventListener document "scroll" onScroll
+      pure $ \_ -> do
+        DOM.removeEventListener document "click" onClick
+        DOM.removeEventListener document "scroll" onScroll
+    Nothing -> pure $ \_ -> pure unit
+          
+documentClickHandler :: forall t. (Maybe t -> Effect Unit) -> DOM.Element -> Callback DE.MouseEvent
+documentClickHandler hide menu =
+  R'.named "hideMenuOnClickOutside" $ callback $ \e ->
+    if Element.contains menu (DE.target e)
+      then pure unit
+      else hide Nothing
+
+documentScrollHandler :: forall t. (Maybe t -> Effect Unit) -> Callback DE.MouseEvent
+documentScrollHandler hide =
+  R'.named "hideMenuOnScroll" $ callback $ \e -> hide Nothing
+
+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"
 
 contextMenuItem :: Array R.Element -> R.Element
 contextMenuItem = R.createElement contextMenuItemCpt {}
@@ -25,73 +95,7 @@ contextMenuItem = R.createElement contextMenuItemCpt {}
 contextMenuItemCpt :: R.Component ()
 contextMenuItemCpt = R.hooksComponent "ContextMenuItem" cpt
   where
-    cpt _props children = pure $ R'.li { className: "context-menu-item" } children
-
-
--- data Action = Show | Hide
-
-
--- contextMenu :: MenuProps -> ReactElement
--- contextMenu props = createElement contextMenuClass props []
-
--- -- TODO: register callbacks
--- componentDidMount :: Effect Unit
--- componentDidMount = pure unit
-
--- -- TODO: unregister callbacks
--- componentWillUnmount :: Effect Unit
--- componentWillUnmount = pure unit
-
--- -- 
--- childRender :: forall s p a. Spec s p a -> Spec s p a
--- childRender = over _render (\c -> wrapItem <<< c)
-
--- -- | Wraps an item in an li tag with the item classname
--- wrapItem :: ReactElement -> ReactElement
--- wrapItem = wrap $ li [ className itemClass ]
-
--- -- TODO: Aria and accessibility
--- renderMenu :: Render State MenuProps Action
--- renderMenu d m s c = pure $ wrap outer $ ul' inner
---   where outer = div [className (classes s.open m.classes)]
---         inner = map (\i -> renderMenuItem d i ) c
-
--- visibilityClass :: Boolean -> String
--- visibilityClass true = contextMenuShown
--- visibilityClass false = contextMenuHidden
-
--- classes :: Boolean -> String -> String
--- classes visible user = joinWith " " [menuClass, visibilityClass visible, user]
-
--- -- Class
-
--- contextMenuClass :: ReactClass (WithChildren State')
--- contextMenuClass = component "ContextMenu" createContextMenuClass
-
--- createContextMenuClass ::
---   forall given snapshot spec.
---   ReactComponentSpec MenuProps State snapshot given spec
---     => ReactClassConstructor MenuProps State given
---     -> ReactClass MenuProps
--- createContextMenuClass this = pure
---   { state: defaultState
---   , render: renderMenu
---   , componentDidMount: componentDidMount
---   , componentWillUnmount: componentWillUnmount
---   }
-
--- type Label = String
--- type ClassName = String
-
--- -- Items
-
--- simpleItem :: Label -> ClassName -> Effect Unit -> ContextConsumer (Effect Unit) -> ReactElement
--- simpleItem label cls cb hide = a [ onClick (hide *> cb), className cls ] [ text label ]
-
--- separator :: Effect Unit -> ReactElement
--- separator _ = li [ className "menu-item-separator" ] []
-
-
+    cpt _props children = pure $ HTML.li { className: "context-menu-item" } children
 
 -- -- CSS Classes
 

src/Gargantext/Utils/Reactix.purs

 module Gargantext.Utils.Reactix
-  ( buff, scuff, nav, ul, li, a)
   where
 
+import Prelude
+import Data.Maybe ( Maybe(..) )
+import Data.Nullable ( Nullable, null, toMaybe )
+import Data.Traversable ( traverse_ )
+import Data.Tuple ( Tuple(..) )
+import Data.Tuple.Nested ( (/\) )
+import DOM.Simple.Event as DE
+import FFI.Simple ( (...), defineProperty )
 import React ( ReactElement )
 import Reactix as R
+import Reactix.SyntheticEvent as RE
 import Unsafe.Coerce ( unsafeCoerce )
+newtype Point = Point { x :: Number, y :: Number }
 
 -- | Turns a ReactElement into a Reactix Element
 -- | buff (v.) to polish
@@ -16,15 +25,9 @@ buff = unsafeCoerce
 scuff :: R.Element -> ReactElement
 scuff = unsafeCoerce
 
-nav :: forall r. Record r -> Array R.Element -> R.Element
-nav = R.createElement "nav"
-
-ul :: forall r. Record r -> Array R.Element -> R.Element
-ul = R.createElement "ul"
-
-li :: forall r. Record r -> Array R.Element -> R.Element
-li = R.createElement "li"
-
-a :: forall r. Record r -> Array R.Element -> R.Element
-a = R.createElement "a"
+mousePosition :: RE.SyntheticEvent DE.MouseEvent -> Point
+mousePosition e = Point { x: RE.clientX e, y: RE.clientY e }
 
+-- | This is naughty, it quietly mutates the input and returns it
+named :: forall o. String -> o -> o
+named = flip $ defineProperty "name"