Skip to content

P
purescript-gargantext
Commit aedbeb27 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

[annotation] some fixes to context menu and annotated fields

parent 5001f21c
Hide whitespace changes
Inline Side-by-side
Showing with 160 additions and 76 deletions
dist/index.html
View file @ aedbeb27
......@@ -8,8 +8,6 @@
<link id="bootstrap-css" href="styles/bootstrap-default.css" rel="stylesheet" />
<link rel="stylesheet" type="text/css" href="styles/highlightjs-solarized-light.css" />
<link href="styles/sass.css" rel="stylesheet" type="text/css" />
<!-- <script type="text/javascript" src="/js/react-bootstrap.min.js"></script> -->
<script type="text/javascript" src="/js/react-bootstrap.js"></script>
<style> * {margin: 0; padding: 0; list-style: none;} </style>
</head>
<body>
......
src/Gargantext/Components/Annotation/AnnotatedField.purs
View file @ aedbeb27
......@@ -22,16 +22,17 @@ import Effect (Effect)
import Reactix as R
import Reactix.DOM.HTML as HTML
import Reactix.SyntheticEvent as E
import Record as Record
import Toestand as T
import Gargantext.Prelude
import Gargantext.Components.Annotation.Menu ( annotationMenu, AnnotationMenu, MenuType(..) )
import Gargantext.Components.Annotation.Menu ( annotationMenuWrapper, AnnotationMenu, MenuType(..) )
import Gargantext.Components.Annotation.Utils (termClass)
import Gargantext.Components.NgramsTable.Core (NgramsTable, NgramsTerm, findNgramTermList, highlightNgrams, normNgram)
import Gargantext.Types (CTabNgramType(..), TermList)
import Gargantext.Utils.Reactix as R2
import Gargantext.Utils.Selection as Sel
import Gargantext.Types (CTabNgramType(..), TermList)
here :: R2.Here
here = R2.here "Gargantext.Components.Annotation.AnnotatedField"
......@@ -48,37 +49,51 @@ type MouseEvent = E.SyntheticEvent DE.MouseEvent
-- defaultProps = { ngrams: NgramsTable Map.empty, text: Nothing, setTermList: \_ _ _ -> pure unit }
annotatedField :: R2.Component Props
annotatedField = R.createElement annotatedFieldComponent
annotatedFieldComponent :: R.Component Props
annotatedFieldComponent = here.component "annotatedField" cpt
where
cpt { ngrams, setTermList, text: fieldText } _ = do
redrawMenu <- T.useBox false
redrawMenu' <- T.useLive T.unequal redrawMenu
annotatedField = R.createElement annotatedFieldCpt
annotatedFieldCpt :: R.Component Props
annotatedFieldCpt = here.component "annotatedField" cpt where
cpt props _ = do
menuRef <- R.useRef (Nothing :: Maybe (Record AnnotationMenu))
redrawMenu <- T.useBox false
pure $ annotatedFieldInner (Record.merge { menuRef, redrawMenu } props)
type InnerProps =
(
menuRef :: R.Ref (Maybe (Record AnnotationMenu))
, redrawMenu :: T.Box Boolean
| Props
)
menuRef <- R.useRef (Nothing :: Maybe (Record AnnotationMenu))
annotatedFieldInner :: R2.Leaf InnerProps
annotatedFieldInner p = R.createElement annotatedFieldInnerCpt p []
annotatedFieldInnerCpt :: R.Component InnerProps
annotatedFieldInnerCpt = here.component "annotatedFieldInner" cpt where
cpt { menuRef, ngrams, redrawMenu, setTermList, text: fieldText } _ = do
-- redrawMenu <- T.useBox false
redrawMenu' <- T.useLive T.unequal redrawMenu
let wrapperProps = { className: "annotated-field-wrapper" }
-- menuRef <- R.useRef (Nothing :: Maybe (Record AnnotationMenu))
-- menu <- T.useBox (Nothing :: Maybe (Record AnnotationMenu))
wrap (text /\ list) = { list
, onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList }
, text }
let wrap (text /\ list) = { list
, onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList }
, text }
pure $ HTML.div wrapperProps
[ maybe (HTML.div {} []) annotationMenu $ R.readRef menuRef
, HTML.div { className: "annotated-field-runs" }
((\p -> annotateRun p []) <$> wrap <$> compile ngrams fieldText)
]
pure $ HTML.div { className: "annotated-field-wrapper" }
[ annotationMenuWrapper { menuRef }
, HTML.div { className: "annotated-field-runs" }
((\p -> annotateRun p []) <$> wrap <$> compile ngrams fieldText)
]
compile :: NgramsTable -> Maybe String -> Array (Tuple String (List (Tuple NgramsTerm TermList)))
compile ngrams = maybe [] (highlightNgrams CTabTerms ngrams)
-- Runs
onAnnotationSelect :: forall e. DE.IsMouseEvent e => { menuRef :: R.Ref (Maybe (Record AnnotationMenu))
, ngrams :: NgramsTable
, redrawMenu :: T.Box Boolean
onAnnotationSelect :: forall e. DE.IsMouseEvent e => { menuRef :: R.Ref (Maybe (Record AnnotationMenu))
, ngrams :: NgramsTable
, redrawMenu :: T.Box Boolean
, setTermList :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit }
-> Maybe (Tuple NgramsTerm TermList) -> E.SyntheticEvent e -> Effect Unit
onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList } Nothing event = do
......@@ -106,12 +121,12 @@ onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList } (Just (Tuple ngr
, setTermList }
-- showMenu :: forall p e. DE.IsMouseEvent e => { event :: E.SyntheticEvent e | p } -> Effect Unit
showMenu :: forall e. DE.IsMouseEvent e => { event :: E.SyntheticEvent e
, getList :: NgramsTerm -> Maybe TermList
, menuRef :: R.Ref (Maybe (Record AnnotationMenu))
, menuType :: MenuType
, ngram :: NgramsTerm
, redrawMenu :: T.Box Boolean
showMenu :: forall e. DE.IsMouseEvent e => { event :: E.SyntheticEvent e
, getList :: NgramsTerm -> Maybe TermList
, menuRef :: R.Ref (Maybe (Record AnnotationMenu))
, menuType :: MenuType
, ngram :: NgramsTerm
, redrawMenu :: T.Box Boolean
, setTermList :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit }
-> Effect Unit
showMenu { event, getList, menuRef, menuType, ngram, redrawMenu, setTermList } = do
......@@ -123,15 +138,16 @@ showMenu { event, getList, menuRef, menuType, ngram, redrawMenu, setTermList } =
setList t = do
setTermList ngram list t
hideMenu { menuRef, redrawMenu }
here.log2 "x" x
here.log2 "y" y
-- here.log2 "x" x
-- here.log2 "y" y
E.preventDefault event
--range <- Sel.getRange sel 0
--here.log2 "selection range" $ Sel.rangeToTuple range
let menu = Just
{ list
, onClose: hideMenu { menuRef, redrawMenu }
, menuType
, onClose: hideMenu { menuRef, redrawMenu }
, redrawMenu
, setList
, x
, y }
......@@ -143,32 +159,25 @@ hideMenu { menuRef, redrawMenu } = do
T.modify_ not redrawMenu
type Run =
( list :: List (Tuple NgramsTerm TermList)
, onSelect :: Maybe (Tuple NgramsTerm TermList) -> MouseEvent -> Effect Unit
, text :: String
( list :: List (Tuple NgramsTerm TermList)
, onSelect :: Maybe (Tuple NgramsTerm TermList) -> MouseEvent -> Effect Unit
, text :: String
)
annotateRun :: R2.Component Run
annotateRun = R.createElement annotatedRunComponent
annotatedRunComponent :: R.Component Run
annotatedRunComponent = R.staticComponent "AnnotatedRun" cpt
annotateRun = R.createElement annotatedRunCpt
annotatedRunCpt :: R.Component Run
annotatedRunCpt = here.component "annotatedRun" cpt
where
cpt { list: Nil, onSelect, text } _ =
HTML.span { on: { mouseUp: onSelect Nothing } } [ HTML.text text ]
cpt { list: lst@((ngram /\ list) : otherLists), onSelect, text } _ =
HTML.span { className
, on: { click: onSelect (Just (ngram /\ list)) } } [ HTML.text text ]
where
bgClasses = joinWith " " $ A.fromFoldable $ termClass <<< snd <$> lst
-- className = "annotation-run bg-" <> termBootstrapClass list
className = "annotation-run " <> bgClasses
-- cb = onSelect text list
-- elt =
-- case list of
-- Nothing -> HTML.span { on: { mouseUp: cb } }
-- Just l -> HTML.span { -- className: "annotation-run bg-" <> termBootstrapClass l
-- className: "annotation-run " <> termClass l
-- , on: { click: cb }
-- }
cpt { list, onSelect, text } _ = do
let el = case list of
Nil -> HTML.span { on: { mouseUp: onSelect Nothing } } [ HTML.text text ]
lst@(( ngram /\ list' ) : otherLists) ->
let bgClasses = joinWith " " $ A.fromFoldable $ termClass <<< snd <$> lst
className = "annotation-run " <> bgClasses
in
HTML.span { className
, on: { click: onSelect (Just (ngram /\ list')) } } [ HTML.text text ]
pure $ el
src/Gargantext/Components/Annotation/Menu.purs
View file @ aedbeb27
......@@ -2,13 +2,17 @@
module Gargantext.Components.Annotation.Menu where
import Prelude (Unit, pure, ($), (<>), (==))
import Data.Array as A
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Uncurried (mkEffectFn1)
import Reactix as R
import Reactix.DOM.HTML as HTML
import Toestand as T
import Gargantext.Prelude
import Gargantext.Types (TermList(..), termListName)
import Gargantext.Components.Annotation.Utils (termBootstrapClass)
......@@ -20,6 +24,9 @@ here :: R2.Here
here = R2.here "Gargantext.Components.Annotation.Menu"
data MenuType = NewNgram | SetTermListItem
derive instance genericMenuType :: Generic MenuType _
instance eqMenuType :: Eq MenuType where
eq = genericEq
type Props =
( list :: Maybe TermList
......@@ -28,19 +35,49 @@ type Props =
)
type AnnotationMenu = (
x :: Number
, y :: Number
, onClose :: Effect Unit
onClose :: Effect Unit
, redrawMenu :: T.Box Boolean
, x :: Number
, y :: Number
| Props
)
type AnnotationMenuWrapper =
(
menuRef :: R.Ref (Maybe (Record AnnotationMenu))
)
eqAnnotationMenu :: Record AnnotationMenu -> Record AnnotationMenu -> Boolean
eqAnnotationMenu new old = new.list == old.list &&
new.menuType == old.menuType &&
new.x == old.x &&
new.y == old.y
eqAnnotationMenuWrapper :: { new :: Maybe (Record AnnotationMenu)
, old :: Maybe (Record AnnotationMenu) } -> Effect Boolean
eqAnnotationMenuWrapper { new: Nothing, old: Nothing } = pure $ true
eqAnnotationMenuWrapper { new: Nothing, old: Just _ } = pure $ false
eqAnnotationMenuWrapper { new: Just _, old: Nothing } = pure $ false
eqAnnotationMenuWrapper { new: Just n, old: Just o } = pure $ eqAnnotationMenu n o
annotationMenuWrapper :: R2.Leaf AnnotationMenuWrapper
annotationMenuWrapper p = R.createElement annotationMenuWrapperCpt p []
annotationMenuWrapperCpt :: R.Component AnnotationMenuWrapper
annotationMenuWrapperCpt = here.component "annotationMenuWrapper" cpt where
cpt { menuRef } _ = do
case R.readRef menuRef of
Nothing -> pure $ HTML.div {} []
Just menu -> pure $ annotationMenu menu
-- | An Annotation Menu is parameterised by a Maybe Termlist of the
-- | TermList the currently selected text belongs to
annotationMenu :: R2.Leaf AnnotationMenu
annotationMenu p = R.createElement annotationMenuCpt p []
annotationMenuCpt :: R.Component AnnotationMenu
annotationMenuCpt = here.component "annotationMenu" cpt where
cpt { x, y, list, menuType, onClose, setList } _ = do
cpt { x, y, list, menuType, onClose, redrawMenu, setList } _ = do
redrawMenu' <- T.useLive T.unequal redrawMenu
pure $ CM.contextMenu {x, y, onClose} [
annotationMenuInner { list, menuType, setList }
]
......
src/Gargantext/Components/App.purs
View file @ aedbeb27
module Gargantext.Components.App (app) where
import Reactix as R
import Toestand as T
import Gargantext.Prelude
......@@ -9,8 +11,6 @@ import Gargantext.Hooks (useHashRouter)
import Gargantext.Router as Router
import Gargantext.Sessions as Sessions
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Toestand as T
here :: R2.Here
here = R2.here "Gargantext.Components.App"
......
src/Gargantext/Components/ContextMenu/ContextMenu.purs
View file @ aedbeb27
......@@ -39,7 +39,9 @@ contextMenuCpt = here.component "contextMenu" cpt
cpt menu@{ x, y, onClose } children = do
host <- R2.getPortalHost
root <- R.useRef null
rect <- T.useBox Nothing
-- rect <- T.useBox $ Just $ R2.domRectFromRect { x, y, width: 224.6, height: 102.0 }
let childRect = R2.boundingRect children
rect <- T.useBox $ Just $ R2.domRectFromRect { x, y, width: childRect.width, height: childRect.height }
rect' <- T.useLive T.unequal rect
R.useLayoutEffect1 (R.readRef root) $ do
......@@ -47,7 +49,7 @@ contextMenuCpt = here.component "contextMenu" cpt
(\r -> T.write_ (Just (Element.boundingRect r)) rect)
(toMaybe $ R.readRef root)
pure $ pure unit
R.useLayoutEffect2 root rect (contextMenuEffect onClose root)
R.useLayoutEffect2 (R.readRef root) rect' (contextMenuEffect onClose root)
let cs = [
HTML.div { className: "popover-content" }
[ HTML.div { className: "card" }
......@@ -64,7 +66,7 @@ contextMenuCpt = here.component "contextMenu" cpt
, style: position menu rect
, data: { placement: "right", toggle: "popover" }
}
elems ref _ _ = HTML.div
elems ref menu Nothing = HTML.div
{ ref
, key: "context-menu"
, className: "context-menu"
......
src/Gargantext/Components/Router.purs
View file @ aedbeb27
......@@ -41,6 +41,7 @@ import Gargantext.Sessions as Sessions
import Gargantext.Types (CorpusId, Handed(..), ListId, NodeID, NodeType(..), SessionId, SidePanelState(..), reverseHanded)
import Gargantext.Utils.Reactix as R2
here :: R2.Here
here = R2.here "Gargantext.Components.Router"
......
src/Gargantext/Utils/Reactix.js
View file @ aedbeb27
......@@ -23,11 +23,16 @@ function setCookie(c) {
document.cookie = c;
}
function domRectFromRect(obj) {
return DOMRectReadOnly.fromRect(obj)
}
exports._addRootElement = addRootElement;
exports._getSelection = getSelection;
exports._stringify = stringify;
exports._postMessage = postMessage;
exports._setCookie = setCookie;
exports._domRectFromRect = domRectFromRect;
exports._keyCode = function(e) {
// https://www.w3schools.com/jsref/event_key_keycode.asp
......
src/Gargantext/Utils/Reactix.purs
View file @ aedbeb27
......@@ -2,22 +2,22 @@ module Gargantext.Utils.Reactix where
import Prelude
import DOM.Simple as DOM
import DOM.Simple.Console (log2)
import DOM.Simple.Document (document)
import DOM.Simple.Element as Element
import DOM.Simple.Event as DE
import DOM.Simple.Types (class IsNode)
import Data.Argonaut as Argonaut
import Data.Argonaut as Json
import Data.Argonaut.Core (Json)
import Data.Array as A
import Data.Either (hush)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Function.Uncurried (Fn1, runFn1, Fn2, runFn2)
import Data.Maybe (Maybe(..), fromJust, fromMaybe, isJust)
import Data.Nullable (Nullable, null, toMaybe)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import DOM.Simple as DOM
import DOM.Simple.Console (log2)
import DOM.Simple.Document (document)
import DOM.Simple.Element as Element
import DOM.Simple.Event as DE
import DOM.Simple.Types (class IsNode, class IsElement, DOMRect)
import Effect (Effect)
import Effect.Console (logShow)
import Effect.Aff (Aff, launchAff, launchAff_, killFiber)
......@@ -398,3 +398,35 @@ setTrigger tRef fun = R.setRef tRef $ Just fun
clearTrigger :: forall a. Trigger a -> Effect Unit
clearTrigger tRef = R.setRef tRef Nothing
type Rect =
( x :: Number
, y :: Number
, width :: Number
, height :: Number )
foreign import _domRectFromRect :: Fn1 (Record Rect) DOMRect
domRectFromRect :: Record Rect -> DOMRect
domRectFromRect = runFn1 _domRectFromRect
boundingRect :: forall e. IsElement e => Array e -> DOMRect
boundingRect els =
case A.uncons els of
Nothing -> domRectFromRect { x: 0.0, y: 0.0, width: 0.0, height: 0.0 }
Just { head, tail } ->
let br = Element.boundingRect head
in
case tail of
[] -> br
_ ->
let brs = boundingRect tail
minx = min br.left brs.left
maxx = max br.right brs.right
miny = min br.top brs.top
maxy = max br.bottom brs.bottom
in
domRectFromRect { x: minx
, y: miny
, width: maxx - minx
, height: maxy - miny }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment