AnnotatedField.purs 4.44 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 16
import Data.Lens ((^?), _Just)
import Data.Lens.At (at)
17
import Data.Maybe ( Maybe(..), maybe, maybe' )
18
import Data.String.Regex as R
19
import Data.String as S
20 21
import Data.Tuple ( Tuple(..) )
import Data.Tuple.Nested ( (/\) )
22
import DOM.Simple.Event as DE
23
import Effect ( Effect )
24
import Effect.Uncurried ( mkEffectFn1 )
25
import Reactix as R
26
import Reactix.DOM.HTML as HTML
27
import Reactix.SyntheticEvent as E
28

29
import Gargantext.Config (CTabNgramType(..))
30
import Gargantext.Types ( TermList )
31
import Gargantext.Components.Annotation.Utils ( termBootstrapClass )
32
import Gargantext.Components.NgramsTable.Core ( NgramsTerm, NgramsTable(..), _NgramsElement, _list, highlightNgrams, findNgramTermList )
33
import Gargantext.Components.Annotation.Menu ( AnnotationMenu, annotationMenu, MenuType(..) )
James Laver's avatar
James Laver committed
34 35
import Gargantext.Utils.Selection as Sel

36
type Props =
37 38 39
  ( ngrams       :: NgramsTable
  , setTermList  :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit
  , text         :: Maybe String
40
  )
41
type MouseEvent = E.SyntheticEvent DE.MouseEvent
42

43 44 45
-- UNUSED
-- defaultProps :: Record Props
-- defaultProps = { ngrams: NgramsTable Map.empty, text: Nothing, setTermList: \_ _ _ -> pure unit }
46

47
annotatedField :: Record Props -> R.Element
48
annotatedField p = R.createElement annotatedFieldComponent p []
49

50
annotatedFieldComponent :: R.Component Props
51
annotatedFieldComponent = R.hooksComponent "AnnotatedField" cpt
52
  where
53
    cpt {ngrams,setTermList,text} _ = do
James Laver's avatar
James Laver committed
54
      menu /\ setMenu <- R.useState $ const Nothing
55
      let wrapperProps =
56
            { className: "annotated-field-wrapper" }
57

58
          onSelect _ Nothing event = maybeShowMenu setMenu setTermList ngrams event
59 60 61
          onSelect text' (Just list) event = do
            let x = E.clientX event
                y = E.clientY event
62
                setList t = do
63
                  setTermList 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 setMenu runs menu]
73

74 75

maybeShowMenu setMenu setTermList ngrams event = do
76 77 78
  s <- Sel.getSelection
  case s of
    Just sel -> do
79
      case Sel.selectionToString sel of
80 81 82
        "" -> pure unit
        sel' -> do
          let x = E.clientX event
83
              y = E.clientY event
84
              list = findNgramTermList CTabTerms ngrams sel'
85
              setList t = do
86
                setTermList sel' list t
James Laver's avatar
James Laver committed
87
                setMenu (const Nothing)
88
          E.preventDefault event
James Laver's avatar
James Laver committed
89
          setMenu (const $ Just { x, y, list, menuType: NewNgram, setList })
90 91
    Nothing -> pure unit

92
maybeAddMenu
James Laver's avatar
James Laver committed
93
  :: ((Maybe AnnotationMenu -> Maybe AnnotationMenu) -> Effect Unit)
94 95 96 97 98 99
  -> R.Element
  -> Maybe AnnotationMenu
  -> R.Element
maybeAddMenu setMenu e (Just props) = annotationMenu setMenu props <> e
maybeAddMenu _ e _ = e

100
compile :: NgramsTable -> Maybe String -> Array (Tuple String (Maybe TermList))
101
compile ngrams = maybe [] (highlightNgrams CTabTerms ngrams)
102

103
-- Runs
104

105 106 107
type Run =
  ( text :: String
  , list :: (Maybe TermList)
108
  , onSelect :: String -> Maybe TermList -> MouseEvent -> Effect Unit
109
  )
110

111
annotateRun :: Record Run -> R.Element
112
annotateRun p = R.createElement annotatedRunComponent p []
113

114
annotatedRunComponent :: R.Component Run
115
annotatedRunComponent = R.staticComponent "AnnotatedRun" cpt
116 117 118 119 120 121
  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
122
                , onClick: mkEffectFn1 $ \e -> onSelect text (Just list) e} [ HTML.text text ]
123
      where
124
        className     list        = "annotation-run bg-" <> termBootstrapClass list
125

126