AnnotatedField.purs 4.64 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

James Laver's avatar
James Laver committed
14
import Prelude
15
import Data.Maybe ( Maybe(..), maybe )
16 17
import Data.Tuple ( Tuple(..) )
import Data.Tuple.Nested ( (/\) )
18
import DOM.Simple.Console (log2)
19
import DOM.Simple.Event as DE
20
import Effect ( Effect )
21
import Effect.Uncurried ( mkEffectFn1 )
22
import Reactix as R
23
import Reactix.DOM.HTML as HTML
24
import Reactix.SyntheticEvent as E
25

26
import Gargantext.Types (CTabNgramType(..), TermList)
27
import Gargantext.Components.Annotation.Utils ( termBootstrapClass )
28
import Gargantext.Components.NgramsTable.Core (NgramsTable, NgramsTerm, findNgramTermList, highlightNgrams, normNgram)
29
import Gargantext.Components.Annotation.Menu ( AnnotationMenu, annotationMenu, MenuType(..) )
James Laver's avatar
James Laver committed
30 31
import Gargantext.Utils.Selection as Sel

32
type Props =
33 34 35
  ( ngrams       :: NgramsTable
  , setTermList  :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit
  , text         :: Maybe String
36
  )
37
type MouseEvent = E.SyntheticEvent DE.MouseEvent
38

39 40 41
-- UNUSED
-- defaultProps :: Record Props
-- defaultProps = { ngrams: NgramsTable Map.empty, text: Nothing, setTermList: \_ _ _ -> pure unit }
42

43
annotatedField :: Record Props -> R.Element
44
annotatedField p = R.createElement annotatedFieldComponent p []
45

46
annotatedFieldComponent :: R.Component Props
47
annotatedFieldComponent = R.hooksComponent "AnnotatedField" cpt
48
  where
49
    cpt {ngrams,setTermList,text} _ = do
50
      mMenu@(_ /\ setMenu) <- R.useState $ const Nothing
51
      let wrapperProps =
52
            { className: "annotated-field-wrapper" }
53

54 55 56
          onSelect text' Nothing event = do
            log2 "[onSelect] text'" text'
            maybeShowMenu setMenu setTermList ngrams event
57
          onSelect text' (Just list) event = do
58 59
            log2 "[onSelect] text'" text'
            log2 "[onSelect] list" list
60 61
            let x = E.clientX event
                y = E.clientY event
62
                setList t = do
63
                  setTermList (normNgram CTabTerms text') (Just list) t
James Laver's avatar
James Laver committed
64 65
                  setMenu (const Nothing)
            setMenu (const $ Just {x, y, list: Just list, menuType: SetTermListItem, setList} )
66 67 68

          mapCompile (Tuple t l) = {text: t, list: l, onSelect}
          compiled = map mapCompile $ compile ngrams text
69

70
          runs =
71
            HTML.div { className: "annotated-field-runs" } $ map annotateRun compiled
72
      pure $ HTML.div wrapperProps [maybeAddMenu mMenu runs]
73

74

75
-- forall e. IsMouseEvent e => R2.Setter (Maybe AnnotationMenu) -> R2.Setter ? -> ? -> e -> Effect Unit
76
maybeShowMenu setMenu setTermList ngrams event = do
77 78 79
  s <- Sel.getSelection
  case s of
    Just sel -> do
80
      case Sel.selectionToString sel of
81 82 83
        "" -> pure unit
        sel' -> do
          let x = E.clientX event
84
              y = E.clientY event
85 86
              n = normNgram CTabTerms sel'
              list = findNgramTermList ngrams n
87
              setList t = do
88
                setTermList n list t
James Laver's avatar
James Laver committed
89
                setMenu (const Nothing)
90
          E.preventDefault event
91 92
          range <- Sel.getRange sel 0
          log2 "[maybeShowMenu] selection range" $ Sel.rangeToTuple range
James Laver's avatar
James Laver committed
93
          setMenu (const $ Just { x, y, list, menuType: NewNgram, setList })
94 95
    Nothing -> pure unit

96
maybeAddMenu
97
  :: R.State (Maybe AnnotationMenu)
98 99
  -> R.Element
  -> R.Element
100 101
maybeAddMenu (Just props /\ setMenu) e = annotationMenu setMenu props <> e
maybeAddMenu _ e = e
102

103
compile :: NgramsTable -> Maybe String -> Array (Tuple String (Maybe TermList))
104
compile ngrams = maybe [] (highlightNgrams CTabTerms ngrams)
105

106
-- Runs
107

108 109 110
type Run =
  ( text :: String
  , list :: (Maybe TermList)
111
  , onSelect :: String -> Maybe TermList -> MouseEvent -> Effect Unit
112
  )
113

114
annotateRun :: Record Run -> R.Element
115
annotateRun p = R.createElement annotatedRunComponent p []
116

117
annotatedRunComponent :: R.Component Run
118
annotatedRunComponent = R.staticComponent "AnnotatedRun" cpt
119 120 121 122 123 124
  where
    cpt    { text, list: Nothing, onSelect }     _ =
      HTML.span { onMouseUp: mkEffectFn1 $ \e -> onSelect text Nothing e } [ HTML.text text ]

    cpt    { text, list: (Just list), onSelect } _ =
      HTML.span { className: className list
125
                , onClick: mkEffectFn1 $ \e -> onSelect text (Just list) e} [ HTML.text text ]
126
      where
127
        className list' = "annotation-run bg-" <> termBootstrapClass list'
128

129