Field.purs 7.57 KB
Newer Older
arturo's avatar
arturo committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
-- | 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.Field where

import Gargantext.Prelude

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 ((/\))
22
import DOM.Simple.Event as DE
arturo's avatar
arturo committed
23 24
import Effect (Effect)
import Gargantext.Components.Annotation.Menu (annotationMenu, AnnotationMenu)
25
import Gargantext.Components.Annotation.Types (MenuType(..), ModeType(..), termClass)
26
import Gargantext.Core.NgramsTable.Functions (findNgramTermList, highlightNgrams, normNgram)
27
import Gargantext.Core.NgramsTable.Types (NgramsTable, NgramsTerm(..))
arturo's avatar
arturo committed
28 29 30 31 32 33 34 35 36 37
import Gargantext.Types (CTabNgramType(..), TermList)
import Gargantext.Utils.Reactix as R2
import Gargantext.Utils.Selection as Sel
import Reactix as R
import Reactix.DOM.HTML as H
import Reactix.SyntheticEvent as E
import Record as Record
import Toestand as T

here :: R2.Here
38
here = R2.here "Gargantext.Components.Annotation.Field"
arturo's avatar
arturo committed
39 40 41 42 43 44

-- @NOTE #386: add parameter "type" ("Authors", "Terms")
type Props =
  ( ngrams       :: NgramsTable
  , setTermList  :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit
  , text         :: Maybe String
45
  , mode         :: ModeType
arturo's avatar
arturo committed
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
  )
type MouseEvent = E.SyntheticEvent DE.MouseEvent

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

annotatedField :: R2.Leaf Props
annotatedField = R2.leaf 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
72
annotatedFieldInner = R2.leaf annotatedFieldInnerCpt
arturo's avatar
arturo committed
73 74
annotatedFieldInnerCpt :: R.Component InnerProps
annotatedFieldInnerCpt = here.component "annotatedFieldInner" cpt where
arturo's avatar
arturo committed
75 76 77 78 79 80 81 82 83
  cpt { menuRef
      , ngrams
      , redrawMenu
      , setTermList
      , text: fieldText
      , mode
      } _ = do
    -- | States
    -- |
arturo's avatar
arturo committed
84 85 86 87
    _redrawMenu' <- T.useLive T.unequal redrawMenu

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

arturo's avatar
arturo committed
88 89 90
    -- | Computed
    -- |
    let
91
      wrap :: Tuple String (List (Tuple NgramsTerm TermList)) -> Record RunProps
arturo's avatar
arturo committed
92 93 94 95 96 97 98 99
      wrap (text /\ list)
        = { list
          , onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList }
          , text
          }

    -- | Render
    -- |
arturo's avatar
arturo committed
100 101 102 103 104 105 106
    pure $

      H.div
      { className: "annotated-field-wrapper" }
      [
        annotationMenu { menuRef }
      ,
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
        case mode of

          EditionMode ->

            H.div
            { className: "annotated-field-runs" }
            ((\p -> annotateRun p) <$> wrap <$> compile ngrams fieldText)


          AdditionMode ->

            R2.fromMaybe fieldText \t ->

              H.div
              { className: "annotated-field-runs" }
              [
                annotateRun
                { list: mempty
                , text: t
                , onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList }
                }
              ]

arturo's avatar
arturo committed
130 131 132 133 134 135 136
      ]

-----------------------------------------------------------

compile ::
     NgramsTable
  -> Maybe String
137
  -> Array (Tuple String (List (Tuple NgramsTerm TermList)))
arturo's avatar
arturo committed
138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
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
160 161
        case (normNgram CTabTerms $ Sel.selectionToString sel) of
          NormNgramsTerm "" -> hideMenu { menuRef, redrawMenu }
arturo's avatar
arturo committed
162 163
          sel' -> do
            showMenu { event
164 165 166 167 168 169
                     , getList: findNgramTermList ngrams
                     , menuRef
                     , menuType: NewNgram
                     , ngram: sel'  -- normNgram CTabTerms sel'
                     , redrawMenu
                     , setTermList }
arturo's avatar
arturo committed
170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
      Nothing -> hideMenu { menuRef, redrawMenu }

onAnnotationSelect
  { menuRef, redrawMenu, setTermList }
  (Just (Tuple ngram list))
  event
    = 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
          , closeCallback: const $ hideMenu { menuRef, redrawMenu }
          , redrawMenu
          , setList
          , x
          , y }
    R.setRef menuRef menu
    T.modify_ not redrawMenu

hideMenu ::
     { menuRef     :: R.Ref (Maybe (Record AnnotationMenu))
     , redrawMenu  :: T.Box Boolean
     }
  -> Effect Unit
hideMenu { menuRef, redrawMenu } = do
  R.setRef menuRef Nothing
  T.modify_ not redrawMenu

--------------------------------------------------

type RunProps =
  ( list       :: List (Tuple NgramsTerm TermList)
  , onSelect   :: Maybe (Tuple NgramsTerm TermList) -> MouseEvent -> Effect Unit
  , text       :: String
  )

annotateRun :: R2.Leaf RunProps
annotateRun = R2.leaf annotatedRunCpt
annotatedRunCpt :: R.Component RunProps
annotatedRunCpt = here.component "annotatedRun" cpt where
  cpt { list, onSelect, text } _ = pure $ case list of

    Nil ->
        H.span
        { on: { mouseUp: onSelect Nothing }
        }
        [ H.text text ]

    lst@(( ngram /\ list' ) : _) ->
      let
        bgClasses
            = joinWith " " $ A.fromFoldable $ termClass
          <<< snd <$> lst

      in
        H.span
        { className: "annotation-run " <> bgClasses
        , on: { click: onSelect (Just (ngram /\ list')) }
        }
        [ H.text text ]