Corpus.Document: wire the ngram/termlist changes

src/Gargantext/Components/Annotation/AnnotatedField.purs

@@ -25,16 +25,21 @@ import Reactix.SyntheticEvent as E
 
 import Gargantext.Types ( TermList )
 import Gargantext.Components.Annotation.Utils ( termClass )
-import Gargantext.Components.NgramsTable.Core ( NgramsTable(..), highlightNgrams )
+import Gargantext.Components.NgramsTable.Core ( NgramsTerm, NgramsTable(..), _NgramsElement, _list, highlightNgrams )
 import Gargantext.Components.Annotation.Menu ( AnnotationMenu, annotationMenu )
 import Gargantext.Utils.Selection as Sel
 
 type Run = Tuple String (Maybe TermList)
 
-type Props = ( ngrams :: NgramsTable, text :: Maybe String )
+type Props =
+  ( ngrams      :: NgramsTable
+  , setTermList :: NgramsTerm -> Maybe TermList -> TermList -> Effect Unit
+  , text        :: Maybe String
+  )
 
-defaultProps :: Record Props
-defaultProps = { ngrams: NgramsTable Map.empty, text: Nothing }
+-- UNUSED
+-- defaultProps :: Record Props
+-- defaultProps = { ngrams: NgramsTable Map.empty, text: Nothing, setTermList: \_ _ _ -> pure unit }
 
 annotatedField :: Record Props -> R.Element
 annotatedField p = R.createElement annotatedFieldComponent p []
@@ -42,14 +47,15 @@ annotatedField p = R.createElement annotatedFieldComponent p []
 annotatedFieldComponent :: R.Component Props
 annotatedFieldComponent = R.hooksComponent "AnnotatedField" cpt
   where
-    runs props =
-      HTML.div { className: "annotated-field-runs" } (map annotateRun $ compile props)
-    cpt props _ = do
+    cpt {ngrams,setTermList,text} _ = do
       menu /\ setMenu <- R.useState $ \_ -> pure Nothing
       let wrapperProps =
             { className: "annotated-field-wrapper"
-            , onContextMenu: mkEffectFn1 (maybeShowMenu setMenu props.ngrams) }
-      pure $ HTML.div wrapperProps [ maybeAddMenu setMenu (runs props) menu]
+            , onContextMenu: mkEffectFn1 (maybeShowMenu setMenu setTermList ngrams)
+            }
+          runs =
+            HTML.div { className: "annotated-field-runs" } $ map annotateRun $ compile ngrams text
+      pure $ HTML.div wrapperProps [maybeAddMenu setMenu runs menu]
 
 maybeAddMenu
   :: (Maybe AnnotationMenu -> Effect Unit)
@@ -59,16 +65,16 @@ maybeAddMenu
 maybeAddMenu setMenu e (Just props) = annotationMenu setMenu props <> e
 maybeAddMenu _ e _ = e
 
-compile :: Record Props -> Array Run
-compile props = runs props.text
-  where runs = maybe [] (highlightNgrams props.ngrams)
+compile :: NgramsTable -> Maybe String -> Array Run
+compile ngrams = maybe [] (highlightNgrams ngrams)
 
 maybeShowMenu
   :: (Maybe AnnotationMenu -> Effect Unit)
+  -> (NgramsTerm -> Maybe TermList -> TermList -> Effect Unit)
   -> NgramsTable
   -> E.SyntheticEvent DE.MouseEvent
   -> Effect Unit
-maybeShowMenu setMenu ngrams event = do
+maybeShowMenu setMenu setTermList ngrams event = do
   s <- Sel.getSelection
   case s of
     Just sel -> do
@@ -76,9 +82,11 @@ maybeShowMenu setMenu ngrams event = do
         "" -> pure unit
         sel' -> do
           let x = E.clientX event
-          let y = E.clientY event
+              y = E.clientY event
+              list = findNgram ngrams sel'
+              setList = setTermList sel' list
           E.preventDefault event
-          setMenu $ Just { x, y, list: findNgram ngrams sel' }
+          setMenu $ Just { x, y, sel, list, setList }
     Nothing -> pure unit
 
 findNgram :: NgramsTable -> String -> Maybe TermList

src/Gargantext/Components/Annotation/Menu.purs

@@ -15,16 +15,23 @@ import Gargantext.Types ( TermList(..), termListName )
 import Gargantext.Components.Annotation.Utils ( termClass )
 
 import Gargantext.Components.ContextMenu.ContextMenu as CM
+import Gargantext.Utils.Selection (Selection, selectionToString)
 
-type Props = ( list :: Maybe TermList )
+type Props =
+  ( sel :: Selection
+  , list :: Maybe TermList
+  , setList :: TermList -> Effect Unit
+  )
 
 type AnnotationMenu = { x :: Number, y :: Number | Props }
 
 -- | An Annotation Menu is parameterised by a Maybe Termlist of the
 -- | TermList the currently selected text belongs to
 annotationMenu :: (Maybe AnnotationMenu -> Effect Unit) -> AnnotationMenu -> R.Element
-annotationMenu setMenu { x,y,list } =
-  CM.contextMenu { x,y,setMenu } [ R.createElement annotationMenuCpt {list} [] ]
+annotationMenu setMenu { x,y,sel,list,setList } =
+  CM.contextMenu { x,y,setMenu } [
+    R.createElement annotationMenuCpt {sel,list,setList} []
+  ]
 
 annotationMenuCpt :: R.Component Props
 annotationMenuCpt = R.hooksComponent "Annotation.Menu" cpt
@@ -36,13 +43,8 @@ annotationMenuCpt = R.hooksComponent "Annotation.Menu" cpt
 addToList :: Record Props -> TermList -> Maybe R.Element
 addToList {list: Just t'} t
   | t == t'   = Nothing
-addToList props t = Just $ CM.contextMenuItem [ link ]
+addToList {setList} t = Just $ CM.contextMenuItem [ link ]
   where link = HTML.a { onClick: click, className: className } [ HTML.text label ]
         label = "Add to " <> termListName t
         className = termClass t
-        click = mkEffectFn1 $ \_ -> addToTermList props t
-
--- TODO: what happens when we add to a term list?
-addToTermList :: Record Props -> TermList -> Effect Unit
-addToTermList _ _ = pure unit
-
+        click = mkEffectFn1 $ \_ -> setList t

src/Gargantext/Components/NgramsTable.purs

@@ -233,7 +233,7 @@ ngramsTableSpec = simpleSpec performAction render
         -- TODO ROOT-UPDATE
         -- patch the root of the child to be equal to the root of the parent.
     performAction (AddNewNgram ngram) {path: params} _ =
-      lift $ addNewNgram ngram params
+      lift $ addNewNgram ngram Nothing params
 
     render :: Render State LoadedNgramsTableProps Action
     render dispatch { path: pageParams

src/Gargantext/Components/NgramsTable/Core.purs

@@ -496,7 +496,7 @@ type CoreState s =
 
 putTable :: {nodeId :: Int, listIds :: Array Int, tabType :: TabType} -> Versioned NgramsTablePatch -> Aff (Versioned NgramsTablePatch)
 putTable {nodeId, listIds, tabType} =
-  put (toUrl Back (PutNgrams tabType (head listIds)) $ Just nodeId)
+  put (toUrl Back (PutNgrams tabType (head listIds) Nothing) $ Just nodeId)
 
 commitPatch :: forall s. {nodeId :: Int, listIds :: Array Int, tabType :: TabType}
             -> Versioned NgramsTablePatch -> StateCoTransformer (CoreState s) Unit
@@ -524,9 +524,9 @@ convOrderBy (T.DESC (T.ColumnName "Score (Occurrences)")) = ScoreDesc
 convOrderBy (T.ASC  _) = TermAsc
 convOrderBy (T.DESC _) = TermDesc
 
-addNewNgram :: forall s. NgramsTerm -> CoreParams s -> Aff Unit
-addNewNgram ngram {nodeId, listIds, tabType} =
-  post (toUrl Back (PutNgrams tabType (head listIds)) $ Just nodeId) [ngram]
+addNewNgram :: forall s. NgramsTerm -> Maybe TermList -> CoreParams s -> Aff Unit
+addNewNgram ngram mayList {nodeId, listIds, tabType} =
+  post (toUrl Back (PutNgrams tabType (head listIds) mayList) $ Just nodeId) [ngram]
 
 ngramsLoaderClass :: Loader.LoaderClass PageParams VersionedNgramsTable
 ngramsLoaderClass = Loader.createLoaderClass "NgramsTableLoader" loadNgramsTable

src/Gargantext/Config.purs

@@ -166,10 +166,11 @@ pathUrl c (GetNgrams
                     _           -> pathUrl c (NodeAPI Url_Document) i
 
 
-pathUrl c (PutNgrams t listid) i =
-    pathUrl c (NodeAPI Node) i <> "/ngrams?ngramsType=" <> showTabType' t <> listid'
-  where
-    listid' = maybe "" (\x -> "&list=" <> show x) listid
+pathUrl c (PutNgrams t listid termList) i =
+    pathUrl c (NodeAPI Node) i <> "/ngrams?ngramsType="
+      <> showTabType' t
+      <> maybe "" (\x -> "&list=" <> show x) listid
+      <> foldMap (\x -> "&listType=" <> show x) termList
 pathUrl c Auth Nothing = c.prePath <> "auth"
 pathUrl c Auth (Just _) = "impossible" -- TODO better types
 pathUrl c (NodeAPI nt) i = c.prePath <> nodeTypeUrl nt <> (maybe "" (\i' -> "/" <> show i') i)
@@ -274,7 +275,7 @@ data Path
       , termSizeFilter :: Maybe TermSize
       , searchQuery    :: String
       }
-  | PutNgrams TabType (Maybe ListId)
+  | PutNgrams TabType (Maybe ListId) (Maybe TermList)
   -- ^ The name is not good. In particular this URL is used both in PUT and POST.
   | NodeAPI NodeType
   | Search  { {-id :: Int

src/Gargantext/Pages/Corpus/Document.purs

@@ -48,7 +48,7 @@ initialState {loaded: {ngramsTable: Versioned {version}}} =
 -- This is a subset of NgramsTable.Action.
 data Action
   = SetTermListItem NgramsTerm (Replace TermList)
-  | AddNewNgram NgramsTerm
+  | AddNewNgram NgramsTerm TermList
   | Refresh
 
 newtype Status = Status { failed    :: Int
@@ -284,8 +284,8 @@ docViewSpec = simpleSpec performAction render
       where
         pe = NgramsPatch { patch_list: pl, patch_children: mempty }
         pt = PatchMap $ Map.singleton n pe
-    performAction (AddNewNgram ngram) {path: params} _ =
-      lift $ addNewNgram ngram params
+    performAction (AddNewNgram ngram termList) {path: params} _ =
+      lift $ addNewNgram ngram (Just termList) params
 
     render :: Render State LoadedDataProps Action
     render dispatch { path: pageParams
@@ -325,7 +325,9 @@ docViewSpec = simpleSpec performAction render
       ]
         where
           ngramsTable = applyNgramsTablePatch ngramsTablePatch initTable
-          annotate text = scuff $ AnnotatedField.annotatedField { ngrams: ngramsTable, text }
+          setTermList ngram Nothing        newList = dispatch $ AddNewNgram ngram newList
+          setTermList ngram (Just oldList) newList = dispatch $ SetTermListItem ngram (replace oldList newList)
+          annotate text = scuff $ AnnotatedField.annotatedField { ngrams: ngramsTable, setTermList, text }
           li' = li [className "list-group-item justify-content-between"]
           text' x = text $ maybe "Nothing" identity x
           badge s = span [className "badge badge-default badge-pill"] [text s]