[ngrams] backend highlights ngrams now

src/Gargantext/Components/Annotation/Field.purs

@@ -11,6 +11,7 @@
 -- | 2. We will need a more ambitious search algorithm for skipgrams.
 module Gargantext.Components.Annotation.Field
   ( annotatedField
+  , annotatedFieldBackend
   )
   where
 
@@ -18,27 +19,36 @@ import Gargantext.Prelude
 
 import DOM.Simple.Event as DE
 import Data.Array as A
+import Data.Either (Either(..))
+import Data.Generic.Rep (class Generic)
 import Data.List (List(..), (:))
 import Data.Map (Map)
 import Data.Map as Map
-import Data.Maybe (Maybe(..), maybe)
+import Data.Maybe (Maybe(..), maybe, fromMaybe)
 import Data.String.Common (joinWith)
 import Data.Tuple (Tuple(..), snd)
 import Data.Tuple.Nested ((/\))
 import Effect (Effect)
+import Effect.Aff (Aff)
+import Effect.Class (liftEffect)
+import Foreign as F
 import Gargantext.Components.Annotation.Menu (annotationMenu, AnnotationMenu)
 import Gargantext.Components.Annotation.Types (MenuType(..), ModeType(..), termClass)
+import Gargantext.Config.REST as REST
 import Gargantext.Core.NgramsTable.Functions (Cache, computeCache, findNgramTermList, highlightNgrams, normNgram)
 import Gargantext.Core.NgramsTable.Types (HighlightElement, NgramsRepoElement(..), NgramsTable(..), NgramsTerm(..), parentMap)
+import Gargantext.Hooks.Loader (useLoader)
 import Gargantext.Types (CTabNgramType(..), TermList)
 import Gargantext.Utils.Reactix as R2
 import Gargantext.Utils.Selection as Sel
+import Gargantext.Utils.SimpleJSON as USJ
 import Gargantext.Utils.Toestand as T2
 import Reactix as R
 import Reactix.DOM.HTML as H
 import Reactix.SyntheticEvent as E
 import Record as Record
 import Record.Extra as RX
+import Simple.JSON as JSON
 import Toestand as T
 
 here :: R2.Here
@@ -61,7 +71,6 @@ type MouseEvent = E.SyntheticEvent DE.MouseEvent
 -- defaultProps :: Record Props
 -- defaultProps = { ngrams: NgramsTable Map.empty, text: Nothing, setTermList: \_ _ _ -> pure unit }
 
-
 annotatedField :: R2.Leaf AnnotatedFieldProps
 annotatedField = R2.leaf annotatedFieldCpt
 annotatedFieldCpt :: R.Component AnnotatedFieldProps
@@ -83,6 +92,176 @@ annotatedFieldCpt = here.component "annotatedField" cpt where
 
 -----------------------------------------------------------------
 
+type AnnotatedFieldBackendProps =
+  ( ngrams'       :: NgramsTable
+  , contextNgrams :: Array NgramsTerm
+  | CommonProps )
+
+annotatedFieldBackend :: R2.Leaf AnnotatedFieldBackendProps
+annotatedFieldBackend = R2.leaf annotatedFieldBackendCpt
+annotatedFieldBackendCpt :: R.Component AnnotatedFieldBackendProps
+annotatedFieldBackendCpt = here.component "annotatedFieldBackend" cpt where
+  cpt props@{ contextNgrams
+            , ngrams'
+            , text } _ = do
+
+    menuRef <- R.useRef (Nothing :: Maybe (Record AnnotationMenu))
+    redrawMenu <- T.useBox false
+    reload <- T.useBox T2.newReload
+
+    let commonProps = RX.pick props :: Record CommonProps
+
+    useLoader { errorHandler
+              , loader: \p -> highlightTerms p.contextNgrams (fromMaybe "" p.text)
+              , path: { contextNgrams, text }
+              , render: \highlightResults ->
+                  let p = Record.merge commonProps { highlightResults
+                                                   , menuRef
+                                                   , ngrams: ngrams'
+                                                   , redrawMenu
+                                                   , reload }
+                  in
+                  annotatedFieldBackendLoaded p }
+    where
+      errorHandler = REST.logRESTError here "[annotatedFieldBackend]"
+
+
+data HighlightResult =
+    HRHighlighted { term         :: String
+                  , originalText :: String
+                  , start        :: Int
+                  , end          :: Int}
+  | HRNormal { text  :: String
+             , start :: Int
+             , end   :: Int }
+derive instance Eq HighlightResult
+derive instance Generic HighlightResult _
+instance JSON.ReadForeign HighlightResult where
+ readImpl f = do
+   inst :: { tag :: String } <- JSON.readImpl f
+   case inst.tag of
+     "HRNormal" -> do
+       inst' :: { contents ::
+                     { text :: String
+                     , start :: Int
+                     , end :: Int } } <- JSON.readImpl f
+       pure $ HRNormal inst'.contents
+     "HRHighlighted" -> do
+       inst' :: { contents ::
+                     { term :: String
+                     , original_text :: String
+                     , start :: Int
+                     , end :: Int } } <- JSON.readImpl f
+       let c = inst'.contents
+       pure $ HRHighlighted { term: c.term
+                            , originalText: c.original_text
+                            , start: c.start
+                            , end: c.end }
+     _ -> USJ.throwJSONError $ F.ForeignError $ "[readForeign HighlightResult] tag " <> inst.tag <> " unknown"
+                       
+highlightTerms :: Array NgramsTerm -> String -> REST.AffRESTError (Array HighlightResult)
+highlightTerms contextNgrams text = do
+  let d = { text
+          , lang: "EN"
+          , terms: (\(NormNgramsTerm t) -> t) <$> contextNgrams }
+  e <- REST.post Nothing "/api/v1.0/public/nlp/highlight-total" d :: REST.AffRESTError (Array HighlightResult)
+  liftEffect $ here.log2 "e" e
+  pure e
+
+
+type AnnotatedFieldBackendLoadedProps =
+  ( highlightResults :: Array HighlightResult
+  , menuRef          :: R.Ref (Maybe (Record AnnotationMenu))
+  , ngrams           :: NgramsTable
+  , redrawMenu       :: T.Box Boolean
+  , reload           :: T2.ReloadS
+  | CommonProps )
+
+annotatedFieldBackendLoaded :: R2.Leaf AnnotatedFieldBackendLoadedProps
+annotatedFieldBackendLoaded = R2.leaf annotatedFieldBackendLoadedCpt
+annotatedFieldBackendLoadedCpt :: R.Component AnnotatedFieldBackendLoadedProps
+annotatedFieldBackendLoadedCpt = here.component "annotatedFieldLoadedBackend" cpt where
+  cpt p@{ highlightResults
+        , menuRef
+        , mode
+        , ngrams
+        , redrawMenu
+        , reload
+        , setTermList
+        , text } _ = do
+    -- | States
+    -- |
+    _redrawMenu' <- T.useLive T.unequal redrawMenu
+
+    -- menu <- T.useBox (Nothing :: Maybe (Record AnnotationMenu))
+
+    -- | Computed
+    -- |
+    let
+      wrap :: HighlightElement -> Record RunProps
+      wrap (text /\ list)
+        = { list
+          , onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, reload, setTermList }
+          , text
+          }
+
+    -- | Render
+    -- |
+    pure $
+
+      H.div
+      { className: "annotated-field-wrapper" }
+      [
+        annotationMenu { menuRef }
+      ,
+        case mode of
+
+          EditionMode ->
+
+            H.div
+            { className: "annotated-field-runs"
+            , aria: { expanded: false }
+            }
+            -- (ht <$> highlightedTerms)
+            (annotateRun <$> wrap <$> highlightElements highlightResults ngrams)
+
+          AdditionMode ->
+
+            R2.fromMaybe text \t ->
+
+              H.div
+              { className: "annotated-field-runs" }
+              [
+                annotateRun
+                { list: mempty
+                , text: t
+                , onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList, reload }
+                }
+              ]
+      ]
+    
+    --where
+      -- ht { term, start, end } = H.span {} [ H.text term ]
+
+      
+-- TODO Recursively highlight (See G.C.N.Types -> HighlightElement)
+-- we need to provide a tuple (String, List (Tuple NgramsTerm TermList))
+-- List in snd of tuple is because a single string can have multiple terms assigned
+highlightElements :: Array HighlightResult -> NgramsTable -> Array HighlightElement
+highlightElements highlightResults (NgramsTable { ngrams_repo_elements }) = h <$> highlightResults
+  where
+    h :: HighlightResult -> HighlightElement
+    h (HRNormal { text }) = Tuple text Nil
+    h (HRHighlighted ht@{ originalText, term }) = Tuple originalText (listAt ht)
+    listAt ht@{ term } =
+      let nt = NormNgramsTerm term
+      in
+      case Map.lookup nt ngrams_repo_elements of
+        Nothing -> Nil
+        Just (NgramsRepoElement { list }) -> (Tuple nt list):Nil
+
+-----------------------------------------------------------------
+
 type InnerProps =
   ( ngrams     :: NgramsTable
   , menuRef    :: R.Ref (Maybe (Record AnnotationMenu))
@@ -113,10 +292,10 @@ annotatedFieldInnerCpt = here.component "annotatedFieldInner" cpt where
     -- | Computed
     -- |
     let
-      wrap :: Tuple String (List (Tuple NgramsTerm TermList)) -> Record RunProps
+      wrap :: HighlightElement -> Record RunProps
       wrap (text /\ list)
         = { list
-          , onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, setTermList, reload}
+          , onSelect: onAnnotationSelect { menuRef, ngrams, redrawMenu, reload, setTermList }
           , text
           }
 

src/Gargantext/Components/Document/Layout.purs

@@ -158,12 +158,20 @@ layoutWithContextNgramsCpt = here.component "layoutWithContextNgrams" cpt where
 
       hasAbstract =  maybe false (not String.null) doc.abstract
 
-      annotate text = AnnotatedField.annotatedField
+      annotate' text = AnnotatedField.annotatedField
+                       { ngrams'
+                       , setTermList
+                       , text
+                       , mode: mode'
+                       , cache
+                       }
+      annotate text = AnnotatedField.annotatedFieldBackend
                       { ngrams'
                       , setTermList
                       , text
                       , mode: mode'
                       , cache
+                      , contextNgrams: contextNgrams'
                       }
 
     -- | Hooks

src/Gargantext/Core/NgramsTable/Functions.purs

@@ -6,6 +6,7 @@ import Gargantext.Prelude
 import Control.Monad.State (class MonadState, execState)
 import Data.Array (head)
 import Data.Array as A
+import Data.Bifunctor (lmap)
 import Data.Either (Either(..))
 import Data.Foldable (foldl)
 import Data.FoldableWithIndex (foldlWithIndex, foldrWithIndex)
@@ -145,6 +146,11 @@ wordBoundaryReg2 = case R.regex ("(" <> wordBoundaryChars <> ")\\1") (R.global <
   Left e  -> unsafePartial $ crashWith e
   Right r -> r
 
+wordBoundaryRegSpc2 :: R.Regex
+wordBoundaryRegSpc2 = case R.regex ("(  )") (R.global <> R.multiline) of
+  Left e  -> unsafePartial $ crashWith e
+  Right r -> r
+
 type Cache =
   ( contextNgrams :: Set NgramsTerm
   , pm            :: Map NgramsTerm NgramsTerm
@@ -183,6 +189,7 @@ highlightNgrams cache@{ pm, pats } ntype table@(NgramsTable {ngrams_repo_element
     -- | substrings, i.e. term "cat" shouldn't match "category"
     sp x = " " <> db x <> " "
     undb = R.replace wordBoundaryReg2 "$1"
+    -- undb = R.replace wordBoundaryRegSpc2 " "
     input = spR input0
     -- pats = A.fromFoldable (Map.keys elts)
     -- pats :: Array NgramsTerm