AnnotatedField.purs 6.78 KB
Newer Older
1 2
-- | The AnnotatedField Component is for colouring ngrams that appear in a text
-- | 
James Laver's avatar
James Laver committed
3
-- | Given an array of ngrams and a text, it:
4 5 6 7 8 9 10 11
-- | 
-- | 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.
James Laver's avatar
James Laver committed
12
module Gargantext.Components.Annotation.AnnotatedField where
13

14
import Data.Array as A
15
import Data.List (List(..), (:))
16
import Data.Maybe ( Maybe(..), maybe )
17 18
import Data.String.Common ( joinWith )
import Data.Tuple (Tuple(..), snd)
19
import Data.Tuple.Nested ( (/\) )
20
import DOM.Simple.Event as DE
21
import Effect (Effect)
22
import Reactix as R
23
import Reactix.DOM.HTML as HTML
24
import Reactix.SyntheticEvent as E
25
import Record as Record
26
import Toestand as T
27

28 29
import Gargantext.Prelude

30
import Gargantext.Components.Annotation.Menu ( annotationMenuWrapper, AnnotationMenu, MenuType(..) )
31
import Gargantext.Components.Annotation.Utils (termClass)
32
import Gargantext.Components.NgramsTable.Core (NgramsTable, NgramsTerm, findNgramTermList, highlightNgrams, normNgram)
33
import Gargantext.Types (CTabNgramType(..), TermList)
34
import Gargantext.Utils.Reactix as R2
James Laver's avatar
James Laver committed
35
import Gargantext.Utils.Selection as Sel
36

37 38
here :: R2.Here
here = R2.here "Gargantext.Components.Annotation.AnnotatedField"
James Laver's avatar
James Laver committed
39

40
type Props =
41 42 43
  ( ngrams       :: NgramsTable
  , setTermList  :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit
  , text         :: Maybe String
44
  )
45
type MouseEvent = E.SyntheticEvent DE.MouseEvent
46

47 48 49
-- UNUSED
-- defaultProps :: Record Props
-- defaultProps = { ngrams: NgramsTable Map.empty, text: Nothing, setTermList: \_ _ _ -> pure unit }
50

51
annotatedField :: R2.Component Props
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66
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
  )
67

68 69 70 71 72 73
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.useLive T.unequal redrawMenu
74

75
    -- menu <- T.useBox (Nothing :: Maybe (Record AnnotationMenu))
76

77 78 79
    let wrap (text /\ list) = { list
                              , onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList }
                              , text }
80

81 82 83 84 85
    pure $ HTML.div { className: "annotated-field-wrapper" }
      [ annotationMenuWrapper { menuRef }
      , HTML.div { className: "annotated-field-runs" }
            ((\p -> annotateRun p []) <$> wrap <$> compile ngrams fieldText)
      ]
86

87
compile :: NgramsTable -> Maybe String -> Array (Tuple String (List (Tuple NgramsTerm TermList)))
88
compile ngrams = maybe [] (highlightNgrams CTabTerms ngrams)
89

90
-- Runs
91

92 93 94
onAnnotationSelect :: forall e. DE.IsMouseEvent e => { menuRef     :: R.Ref (Maybe (Record AnnotationMenu))
                                              , ngrams      :: NgramsTable
                                              , redrawMenu  :: T.Box Boolean
95 96 97
                                              , setTermList :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit }
                      -> Maybe (Tuple NgramsTerm TermList) -> E.SyntheticEvent e -> Effect Unit
onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList } Nothing event = do
98 99 100 101
  s <- Sel.getSelection
  case s of
    Just sel -> do
      case Sel.selectionToString sel of
102
        "" -> hideMenu { menuRef, redrawMenu }
103 104 105 106 107 108
        sel' -> do
          showMenu { event
                   , getList: findNgramTermList ngrams
                   , menuRef
                   , menuType: NewNgram
                   , ngram: normNgram CTabTerms sel'
109
                   , redrawMenu
110
                   , setTermList }
111
    Nothing -> hideMenu { menuRef, redrawMenu }
112
onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList } (Just (Tuple ngram list)) event = do
113 114 115 116 117
  showMenu { event
           , getList: const (Just list)
           , menuRef
           , menuType: SetTermListItem
           , ngram
118
           , redrawMenu
119 120
           , setTermList }

121
-- showMenu :: forall p e. DE.IsMouseEvent e => { event :: E.SyntheticEvent e | p } -> Effect Unit
122 123 124 125 126 127
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
128 129 130
                                    , setTermList :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit }
            -> Effect Unit
showMenu { event, getList, menuRef, menuType, ngram, redrawMenu, setTermList } = do
131 132
  let x = E.clientX event
      y = E.clientY event
133 134
      -- n = normNgram CTabTerms text
      list = getList ngram
135
      -- redrawMenu = T.modify not redrawMenu
136
      setList t = do
137
        setTermList ngram list t
138
        hideMenu { menuRef, redrawMenu }
139 140
  E.preventDefault event
  --range <- Sel.getRange sel 0
141
  --here.log2 "selection range" $ Sel.rangeToTuple range
142
  let menu = Just
143
        { list
144
        , menuType
145 146
        , onClose: hideMenu { menuRef, redrawMenu }
        , redrawMenu
147
        , setList
148 149
        , x
        , y }
150
  R.setRef menuRef menu
151
  T.modify_ not redrawMenu
152

153
hideMenu { menuRef, redrawMenu } = do
154
  R.setRef menuRef Nothing
155
  T.modify_ not redrawMenu
156

157
type Run =
158 159 160
  ( list       :: List (Tuple NgramsTerm TermList)
  , onSelect   :: Maybe (Tuple NgramsTerm TermList) -> MouseEvent -> Effect Unit
  , text       :: String
161
  )
162

163
annotateRun :: R2.Component Run
164 165 166
annotateRun = R.createElement annotatedRunCpt
annotatedRunCpt :: R.Component Run
annotatedRunCpt = here.component "annotatedRun" cpt
167
  where
168 169 170 171 172 173 174 175 176 177 178 179
    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