1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
-- | The AnnotatedField Component is for colouring ngrams that appear in a text
-- |
-- | Given an array of ngrams and a text, it:
-- |
-- | 1. Searches the text for the ngrams
-- | 2. Renders each the resulting runs according to the Maybe TermList they appear in
-- |
-- | Notes:
-- |
-- | 1. We must only re-search the text when the ngrams change for performance
-- | 2. We will need a more ambitious search algorithm for skipgrams.
module Gargantext.Components.Annotation.AnnotatedField where
import Data.Array as A
import Data.List (List(..), (:))
import Data.Maybe ( Maybe(..), maybe )
import Data.String.Common ( joinWith )
import Data.Tuple (Tuple(..), snd)
import Data.Tuple.Nested ( (/\) )
import DOM.Simple.Event as DE
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 ( 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
here :: R2.Here
here = R2.here "Gargantext.Components.Annotation.AnnotatedField"
type Props =
( ngrams :: NgramsTable
, setTermList :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit
, text :: Maybe String
)
type MouseEvent = E.SyntheticEvent DE.MouseEvent
-- UNUSED
-- defaultProps :: Record Props
-- defaultProps = { ngrams: NgramsTable Map.empty, text: Nothing, setTermList: \_ _ _ -> pure unit }
annotatedField :: R2.Component Props
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
)
annotatedFieldInner :: R2.Leaf InnerProps
annotatedFieldInner = R2.leafComponent annotatedFieldInnerCpt
annotatedFieldInnerCpt :: R.Component InnerProps
annotatedFieldInnerCpt = here.component "annotatedFieldInner" cpt where
cpt { menuRef, ngrams, redrawMenu, setTermList, text: fieldText } _ = do
_redrawMenu' <- T.useLive T.unequal redrawMenu
-- menu <- T.useBox (Nothing :: Maybe (Record AnnotationMenu))
let wrap (text /\ list) = { list
, onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList }
, text }
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
, setTermList :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit }
-> Maybe (Tuple NgramsTerm TermList) -> E.SyntheticEvent e -> Effect Unit
onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList } Nothing event = do
s <- Sel.getSelection
case s of
Just sel -> do
case Sel.selectionToString sel of
"" -> hideMenu { menuRef, redrawMenu }
sel' -> do
showMenu { event
, getList: findNgramTermList ngrams
, menuRef
, menuType: NewNgram
, ngram: normNgram CTabTerms sel'
, redrawMenu
, setTermList }
Nothing -> hideMenu { menuRef, redrawMenu }
onAnnotationSelect { menuRef, redrawMenu, setTermList } (Just (Tuple ngram list)) event = do
showMenu { event
, getList: const (Just list)
, menuRef
, menuType: SetTermListItem
, ngram
, redrawMenu
, 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
, setTermList :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit }
-> Effect Unit
showMenu { event, getList, menuRef, menuType, ngram, redrawMenu, setTermList } = do
let x = E.clientX event
y = E.clientY event
-- n = normNgram CTabTerms text
list = getList ngram
-- redrawMenu = T.modify not redrawMenu
setList t = do
setTermList ngram list t
hideMenu { menuRef, redrawMenu }
E.preventDefault event
--range <- Sel.getRange sel 0
--here.log2 "selection range" $ Sel.rangeToTuple range
let menu = Just
{ list
, menuType
, onClose: hideMenu { menuRef, redrawMenu }
, redrawMenu
, setList
, x
, y }
R.setRef menuRef menu
T.modify_ not redrawMenu
hideMenu { menuRef, redrawMenu } = do
R.setRef menuRef Nothing
T.modify_ not redrawMenu
type Run =
( list :: List (Tuple NgramsTerm TermList)
, onSelect :: Maybe (Tuple NgramsTerm TermList) -> MouseEvent -> Effect Unit
, text :: String
)
annotateRun :: R2.Component Run
annotateRun = R.createElement annotatedRunCpt
annotatedRunCpt :: R.Component Run
annotatedRunCpt = here.component "annotatedRun" cpt
where
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