[NGRAMS] grouping

src/Gargantext/Pages/Corpus/Tabs/Ngrams/NgramsTable.purs

 module Gargantext.Pages.Corpus.Tabs.Ngrams.NgramsTable where
 
 
+import Control.Monad.State (class MonadState, execState)
 import Data.Argonaut (class DecodeJson, decodeJson, (.?), (.??))
 import Data.Array (filter, toUnfoldable)
 import Data.Either (Either(..))
+import Data.Foldable
+import Data.FoldableWithIndex
 import Data.FunctorWithIndex
 import Data.Newtype (class Newtype, unwrap)
-import Data.Lens (Lens', Prism', lens, over, prism, (^..))
+import Data.Lens (Lens', Prism', Iso', lens, over, prism, (^.), (^..), (%~), (.=), use, (<>~))
+import Data.Lens.Common (_Just)
 import Data.Lens.At (class At, at)
 import Data.Lens.Index (class Index, ix)
 import Data.Lens.Fold (folded)
 import Data.Lens.Getter (to)
+import Data.Lens.Record (prop)
 import Data.Lens.Iso (re)
 import Data.Lens.Iso.Newtype (_Newtype)
 import Data.List (List)
@@ -18,9 +23,11 @@ import Data.List as List
 import Data.Map (Map)
 import Data.Map as Map
 import Data.Maybe (Maybe(..), maybe)
-import Data.Traversable (traverse)
+import Data.Traversable (class Traversable, traverse, traverse_, sequence)
+import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
 import Data.Set (Set)
 import Data.Set as Set
+import Data.Symbol (SProxy(..))
 import Data.Tuple (Tuple(..), uncurry)
 import Data.Void (Void)
 import Data.Unit (Unit)
@@ -58,22 +65,29 @@ newtype NgramsElement = NgramsElement
   { ngrams      :: NgramsTerm
   , list        :: TermList
   , occurrences :: Int
-  , root        :: Maybe NgramsTerm
+  , parent      :: Maybe NgramsTerm
   , children    :: Set NgramsTerm
   }
 
+_parent = prop (SProxy :: SProxy "parent")
+_children :: forall row. Lens' { children :: Set NgramsTerm | row } (Set NgramsTerm)
+_children = prop (SProxy :: SProxy "children")
+
 derive instance newtypeNgramsElement :: Newtype NgramsElement _
 
+_NgramsElement :: Iso' NgramsElement _
+_NgramsElement = _Newtype
+
 instance decodeJsonNgramsElement :: DecodeJson NgramsElement where
   decodeJson json = do
     obj <- decodeJson json
     ngrams <- obj .? "ngrams"
     list <- obj .? "list"
     occurrences <- obj .? "occurrences"
-    root <- obj .?? "root"
+    parent <- obj .?? "parent"
     children' <- obj .? "children"
     let children = Set.fromFoldable (children' :: Array NgramsTerm)
-    pure $ NgramsElement {ngrams, list, occurrences, root, children}
+    pure $ NgramsElement {ngrams, list, occurrences, parent, children}
 
 -- type NgramsTable = Array (NTree NgramsElement)
 -- type NgramsTable = Array NgramsElement
@@ -81,11 +95,14 @@ newtype NgramsTable = NgramsTable (Map NgramsTerm NgramsElement)
 
 derive instance newtypeNgramsTable :: Newtype NgramsTable _
 
+_NgramsTable :: Iso' NgramsTable (Map NgramsTerm NgramsElement)
+_NgramsTable = _Newtype
+
 instance indexNgramsTable :: Index NgramsTable String NgramsElement where
-  ix k = _Newtype <<< ix k
+  ix k = _NgramsTable <<< ix k
 
 instance atNgramsTable :: At NgramsTable String NgramsElement where
-  at k = _Newtype <<< at k
+  at k = _NgramsTable <<< at k
 
 instance decodeJsonNgramsTable :: DecodeJson NgramsTable where
   decodeJson json = do
@@ -121,6 +138,8 @@ applyReplace (Replace { old, new }) a
   | a == old  = new
   | otherwise = a
 
+-- Representing a PatchSet as `Map a Boolean` would have the advantage
+-- of enforcing rem and add to be disjoint.
 newtype PatchSet a = PatchSet
   { rem :: Set a
   , add :: Set a
@@ -138,6 +157,11 @@ instance monoidPatchSet :: Ord a => Monoid (PatchSet a) where
 applyPatchSet :: forall a. Ord a => PatchSet a -> Set a -> Set a
 applyPatchSet (PatchSet p) s = Set.difference s p.rem <> p.add
 
+patchSetFromMap :: forall a. Ord a => Map a Boolean -> PatchSet a
+patchSetFromMap m = PatchSet { rem: Map.keys (Map.filter not m)
+                             , add: Map.keys (Map.filter identity m) }
+  -- TODO Map.partition would be nice here
+
 newtype NgramsPatch = NgramsPatch
   { patch_children :: PatchSet NgramsTerm
   , patch_list     :: Replace TermList
@@ -157,8 +181,7 @@ applyNgramsPatch (NgramsPatch p) (NgramsElement e) = NgramsElement
   { ngrams:      e.ngrams
   , list:        applyReplace p.patch_list e.list
   , occurrences: e.occurrences -- TODO: is this correct ?
-  , root:        e.root -- TODO: is this correct ?
-                        -- See ROOT-UPDATE
+  , parent:      e.parent
   , children:    applyPatchSet p.patch_children e.children
   }
 
@@ -170,6 +193,34 @@ instance semigroupPatchMap :: (Ord k, Semigroup p) => Semigroup (PatchMap k p) w
 instance monoidPatchMap :: (Ord k, Semigroup p) => Monoid (PatchMap k p) where
   mempty = PatchMap Map.empty
 
+derive instance newtypePatchMap :: Newtype (PatchMap k p) _
+
+_PatchMap :: forall k p. Iso' (PatchMap k p) (Map k p)
+_PatchMap = _Newtype
+
+instance functorPatchMap :: Functor (PatchMap k) where
+  map f (PatchMap m) = PatchMap (map f m)
+
+instance functorWithIndexPatchMap :: FunctorWithIndex k (PatchMap k) where
+  mapWithIndex f (PatchMap m) = PatchMap (mapWithIndex f m)
+
+instance foldlablePatchMap :: Foldable (PatchMap k) where
+  foldr f z (PatchMap m) = foldr f z m
+  foldl f z (PatchMap m) = foldl f z m
+  foldMap f (PatchMap m) = foldMap f m
+
+instance foldlableWithIndexPatchMap :: FoldableWithIndex k (PatchMap k) where
+  foldrWithIndex f z (PatchMap m) = foldrWithIndex f z m
+  foldlWithIndex f z (PatchMap m) = foldlWithIndex f z m
+  foldMapWithIndex f (PatchMap m) = foldMapWithIndex f m
+
+instance traversablePatchMap :: Traversable (PatchMap k) where
+  traverse f (PatchMap m) = PatchMap <$> traverse f m
+  sequence (PatchMap m) = PatchMap <$> sequence m
+
+instance traversableWithIndexPatchMap :: TraversableWithIndex k (PatchMap k) where
+  traverseWithIndex f (PatchMap m) = PatchMap <$> traverseWithIndex f m
+
 applyPatchMap :: forall k p v. Ord k => (p -> v -> v) -> PatchMap k p -> Map k v -> Map k v
 applyPatchMap applyPatchValue (PatchMap p) = mapWithIndex f
   where
@@ -180,22 +231,48 @@ applyPatchMap applyPatchValue (PatchMap p) = mapWithIndex f
 
 type NgramsTablePatch = PatchMap NgramsTerm NgramsPatch
 
+type ReParent a = forall m. MonadState NgramsTable m => a -> m Unit
+
+reParent :: Maybe NgramsTerm -> ReParent NgramsTerm
+reParent parent child =
+  at child <<< _Just <<< _NgramsElement <<< _parent .= parent
+
+-- reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
+-- ^ GHC would have accepted this type. Here reParentNgramsPatch checks but
+--   not its usage in reParentNgramsTablePatch.
+reParentNgramsPatch :: forall m. MonadState NgramsTable m
+                    => NgramsTerm -> NgramsPatch -> m Unit
+reParentNgramsPatch parent (NgramsPatch {patch_children: PatchSet {rem, add}}) = do
+  traverse_ (reParent Nothing) rem
+  traverse_ (reParent $ Just parent) add
+
+reParentNgramsTablePatch :: ReParent NgramsTablePatch
+reParentNgramsTablePatch = void <<< traverseWithIndex reParentNgramsPatch
+
 applyNgramsTablePatch :: NgramsTablePatch -> NgramsTable -> NgramsTable
 applyNgramsTablePatch p (NgramsTable m) =
-  NgramsTable (applyPatchMap applyNgramsPatch p m)
+  execState (reParentNgramsTablePatch p) $
+  NgramsTable $ applyPatchMap applyNgramsPatch p m
     -- TODO: update the .root fields...
     -- See ROOT-UPDATE
 
 type State =
   { ngramsTablePatch :: NgramsTablePatch
+  , ngramsParent     :: Maybe NgramsTerm -- Nothing means we are not currently grouping terms
+  , ngramsChildren   :: Set NgramsTerm   -- Used only when grouping, this is the set
+                                         -- of future children of `ngramsParent`.
   , searchQuery      :: String
   , termListFilter   :: Maybe TermList -- Nothing means all
   , termTypeFilter   :: Maybe TermType -- Nothing means all
   }
 
+_ngramsChildren = prop (SProxy :: SProxy "ngramsChildren")
+
 initialState :: forall props. props -> State
 initialState _ =
   { ngramsTablePatch: mempty
+  , ngramsParent:     Nothing
+  , ngramsChildren:   mempty
   , searchQuery:      ""
   , termListFilter:   Nothing
   , termTypeFilter:   Nothing
@@ -203,7 +280,16 @@ initialState _ =
 
 data Action
   = SetTermListItem NgramsTerm (Replace TermList)
-  | AddTermChildren { parent :: NgramsTerm, child :: NgramsTerm }
+  | SetParentResetChildren (Maybe NgramsTerm)
+  -- ^ This sets `ngramsParent` and resets `ngramsChildren`.
+  | ToggleChild Boolean NgramsTerm
+  -- ^ Toggles the NgramsTerm in the `PatchSet` `ngramsChildren`.
+  -- If the `Boolean` is `true` it means we want to add it if it is not here,
+  -- if it is `false` it is meant to be removed if not here.
+  | AddTermChildren -- NgramsTable
+  -- ^ The NgramsTable argument is here as a cache of `ngramsTablePatch`
+  -- applied to `initTable`.
+  -- TODO more docs
   | SetTermListFilter (Maybe TermList)
   | SetTermTypeFilter (Maybe TermType)
   | SetSearchQuery String
@@ -212,8 +298,14 @@ data Mode = Authors | Sources | Terms | Trash
 
 type Dispatch = Action -> Effect Unit
 
-tableContainer :: {searchQuery :: String, dispatch :: Dispatch} -> T.TableContainerProps -> Array ReactElement
-tableContainer {searchQuery, dispatch} props =
+tableContainer :: { searchQuery :: String
+                  , dispatch :: Dispatch
+                  , ngramsParent :: Maybe NgramsTerm
+                  , ngramsChildren :: Map NgramsTerm Boolean
+                  , ngramsTable :: NgramsTable
+                  }
+               -> T.TableContainerProps -> Array ReactElement
+tableContainer {searchQuery, dispatch, ngramsParent, ngramsChildren, ngramsTable: ngramsTableCache} props =
   [ div [className "container-fluid"]
     [ div [className "jumbotron1"]
       [ div [className "row"]
@@ -262,6 +354,23 @@ tableContainer {searchQuery, dispatch} props =
                 ]
               ]
             ]
+          , div [] (maybe [] (\ngrams ->
+              let
+                ngramsTable =
+                  ngramsTableCache # at ngrams
+                                 <<< _Just
+                                 <<< _NgramsElement
+                                 <<< _children
+                                 %~ applyPatchSet (patchSetFromMap ngramsChildren)
+                ngramsClick child
+                  | child == ngrams = Nothing
+                  | otherwise       = Just $ dispatch $ ToggleChild false child
+              in
+              [ p[] [text $ "Editing " <> ngrams]
+              , renderNgramsTree { ngramsTable, ngrams, ngramsStyle: [], ngramsClick }
+              , button [className "btn btn-primary", onClick $ const $ dispatch $ AddTermChildren] [text "Save"]
+              , button [className "btn btn-secondary", onClick $ const $ dispatch $ SetParentResetChildren Nothing] [text "Cancel"]
+              ]) ngramsParent)
           , div [ _id "terms_table", className "panel-body" ]
                 [ table [ className "table able table-bordered" ]
                   [ thead [ className "tableHeader table-bordered"] [props.tableHead]
@@ -277,27 +386,42 @@ tableContainer {searchQuery, dispatch} props =
 commitPatch :: NgramsTablePatch -> StateCoTransformer State Unit
 commitPatch pt = modifyState_ $ \s -> s { ngramsTablePatch = pt <> s.ngramsTablePatch }
 
+toggleMap :: forall a. a -> Maybe a -> Maybe a
+toggleMap _ (Just _) = Nothing
+toggleMap b Nothing  = Just b
+
 ngramsTableSpec' :: Spec State Props' Action
 ngramsTableSpec' = simpleSpec performAction render
   where
+    setParentResetChildren :: Maybe NgramsTerm -> State -> State
+    setParentResetChildren p = _ { ngramsParent = p, ngramsChildren = mempty }
+
     performAction :: PerformAction State Props' Action
     performAction (SetTermListFilter c) _ _ = modifyState_ $ _ { termListFilter = c }
     performAction (SetTermTypeFilter c) _ _ = modifyState_ $ _ { termTypeFilter = c }
     performAction (SetSearchQuery s) _ _ = modifyState_ $ _ { searchQuery = s }
+    performAction (SetParentResetChildren p) _ _ =
+      modifyState_ $ setParentResetChildren p
+    performAction (ToggleChild b c) _ _ =
+      modifyState_ $ _ngramsChildren <<< at c %~ toggleMap b
     performAction (SetTermListItem n pl) _ _ = commitPatch pt
       where
         pe = NgramsPatch { patch_list: pl, patch_children: mempty }
         pt = PatchMap $ Map.singleton n pe
-    performAction (AddTermChildren { parent, child {- , child_root, parent_root -} }) _ _ = commitPatch pt
+    performAction AddTermChildren _ {ngramsParent: Nothing} =
+        -- impossible but harmless
+        pure unit
+    performAction AddTermChildren _
+                  { ngramsParent: Just parent
+                  , ngramsChildren
+                  , ngramsTablePatch
+                  } = do
+        modifyState_ $ setParentResetChildren Nothing
+        commitPatch pt
       where
-        pc = PatchSet { rem: mempty, add: Set.singleton child }
+        pc = patchSetFromMap ngramsChildren
         pe = NgramsPatch { patch_list: mempty, patch_children: pc }
-     -- pr = NgramsPatch { patch_list: mempty
-     --                  , patch_children: mempty
-     --                  , patch_root: replace child_root parent_root
-     --                  }
         pt = PatchMap $ Map.fromFoldable [Tuple parent pe]
-                                      -- ,Tuple child pr]
         -- TODO ROOT-UPDATE
         -- patch the root of the child to be equal to the root of the parent.
 
@@ -305,11 +429,12 @@ ngramsTableSpec' = simpleSpec performAction render
     render dispatch { path: {nodeId}
                     , loaded: initTable
                     , dispatch: loaderDispatch }
-                    { ngramsTablePatch, searchQuery } _children =
+                    { ngramsTablePatch, ngramsParent, ngramsChildren, searchQuery }
+                    _reactChildren =
       [ T.tableElt
           { rows
           , setParams: \params -> loaderDispatch (Loader.SetPath {nodeId, params})
-          , container: tableContainer {searchQuery, dispatch}
+          , container: tableContainer {searchQuery, dispatch, ngramsParent, ngramsChildren, ngramsTable}
           , colNames:
               T.ColumnName <$>
               [ "Graph"
@@ -321,22 +446,34 @@ ngramsTableSpec' = simpleSpec performAction render
           }
       ]
           where
-            rows =
+            ngramsTable =
               case applyNgramsTablePatch ngramsTablePatch <$> initTable of
-                Nothing -> [] -- or an error
-                Just t@(NgramsTable table) ->
-                  convertRow t <$> Map.toUnfoldable (Map.filter isRoot table)
-            isRoot (NgramsElement e) = e.root == Nothing
-            convertRow table (Tuple ngrams (NgramsElement { occurrences, list })) =
+                Nothing -> NgramsTable mempty
+                Just t -> t
+            rows = convertRow <$> Map.toUnfoldable (Map.filter displayRow (ngramsTable ^. _NgramsTable))
+            isRoot (NgramsElement e) = e.parent == Nothing
+            -- TODO: There is a missing case where we display a row that we should not.
+            -- Assumptions:
+            --   * cats -> cat -> animal
+            --   * We are editing cats: ngramsParent == Just "cats"
+            --   * animal should not be listed since this would create a cycle!
+            displayRow e@(NgramsElement {ngrams, children, parent}) =
+              isRoot e
+                -- ^ Display only nodes with parents
+                      && (ngramsChildren ^. at ngrams /= Just true)
+                      -- ^ and which are not scheduled to be added already.
+                      && (case ngramsParent of
+                            Just p ->
+                              ngrams /= p &&
+                              -- ^ and which is not the node being currently edited.
+                              not (Set.member p children)
+                              -- ^ ... or one of its children.
+                            Nothing -> true)
+              || -- Unless they are scheduled to be removed.
+                 (ngramsChildren ^. at ngrams == Just false)
+            convertRow (Tuple ngrams (NgramsElement { occurrences, list })) =
               { row:
-                  let
-                    setTermList Keep = do
-                      logs "setTermList Keep"
-                      pure unit
-                    setTermList rep@(Replace {old,new}) = do
-                      logs $ Tuple "setTermList" (Tuple old new)
-                      dispatch $ SetTermListItem ngrams rep in
-                  renderNgramsItem { table, ngrams, occurrences, termList: list, setTermList }
+                  renderNgramsItem { ngramsTable, ngrams, occurrences, ngramsParent, termList: list, dispatch }
               , delete: false
               }
 
@@ -367,39 +504,66 @@ ngramsTableSpec = simpleSpec defaultPerformAction render
     render _ {path: nodeId} _ _ =
       -- TODO: ignored mode, ignored loaded: corpusInfo
       [ ngramsLoader { path: initialPageParams nodeId
-                     , component: createClass "Layout" ngramsTableSpec' initialState
+                     , component: createClass "NgramsTableLayout" ngramsTableSpec' initialState
                      } ]
 
-tree :: NgramsTable -> DOM.Props -> NgramsTerm -> ReactElement
-tree table props label =
+tree :: { ngramsTable :: NgramsTable
+        , ngramsStyle :: Array DOM.Props
+        , ngramsClick :: NgramsTerm -> Maybe (Effect Unit)
+        } -> NgramsTerm -> ReactElement
+tree params@{ngramsTable, ngramsStyle, ngramsClick} label =
   li [ style {width : "100%"} ]
-     [ i (gray <> [className $ "fas fa-caret-" <> if open then "down" else "right"]) []
-     , span [props] [text $ " " <> label]
-     , forest table props cs
+     [ i icon []
+     , tag [text $ " " <> label]
+     , forest cs
      ]
   where
+    tag =
+      case ngramsClick label of
+        Just effect ->
+          a (ngramsStyle <> [onClick $ const effect])
+        Nothing ->
+          span ngramsStyle
     leaf = List.null cs
+    icon = gray <> [className $ "fas fa-caret-" <> if open then "down" else "right"]
     open = not leaf || false {- TODO -}
     gray = if leaf then [style {color: "#adb5bd"}] else []
-    cs   = table ^.. ix label <<< _Newtype <<< to _.children <<< folded
-
-forest :: NgramsTable -> DOM.Props -> List NgramsTerm -> ReactElement
-forest table props = ul [] <<< map (tree table props) <<< List.toUnfoldable
+    cs   = ngramsTable ^.. ix label <<< _NgramsElement <<< _children <<< folded
+
+    forest = ul [] <<< map (tree params) <<< List.toUnfoldable
+
+renderNgramsTree :: { ngrams      :: NgramsTerm
+                    , ngramsTable :: NgramsTable
+                    , ngramsStyle :: Array DOM.Props
+                    , ngramsClick :: NgramsTerm -> Maybe (Effect Unit)
+                    } -> ReactElement
+renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick } =
+  ul [] [
+    span [className "tree"] [tree {ngramsTable, ngramsStyle, ngramsClick} ngrams]
+  ]
 
-renderNgramsItem :: { table :: NgramsTable
-                    , ngrams :: String
+renderNgramsItem :: { ngrams :: NgramsTerm
+                    , ngramsTable :: NgramsTable
                     , occurrences :: Int
                     , termList :: TermList
-                    , setTermList :: Replace TermList -> Effect Unit
+                    , ngramsParent :: Maybe NgramsTerm
+                    , dispatch :: Action -> Effect Unit
                     } -> Array ReactElement
-renderNgramsItem { table, ngrams, occurrences, termList, setTermList } =
+renderNgramsItem { ngramsTable, ngrams, occurrences, termList, ngramsParent, dispatch } =
   [ checkbox GraphTerm
   , checkbox StopTerm
-  , ul [] [span [className "tree"] [tree table (termStyle termList) ngrams]]
+  , if ngramsParent == Nothing
+    then renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick }
+    else
+      a [onClick $ const $ dispatch $ ToggleChild true ngrams]
+        [ i [className "fas fa-plus"] []
+        , span ngramsStyle [text $ " " <> ngrams]
+        ]
   , text $ show occurrences
   ]
   where
-
+    ngramsStyle = [termStyle termList]
+    ngramsClick = Just <<< dispatch <<< SetParentResetChildren <<< Just
     checkbox termList' =
       let chkd = termList == termList'
           termList'' = if chkd then CandidateTerm else termList'
@@ -412,6 +576,9 @@ renderNgramsItem { table, ngrams, occurrences, termList, setTermList } =
         , onChange $ const $ setTermList (replace termList termList'')
         ]
 
+    setTermList Keep = pure unit
+    setTermList rep@(Replace {old,new}) = dispatch $ SetTermListItem ngrams rep
+
 termStyle :: TermList -> DOM.Props
 termStyle GraphTerm     = style {color: "green"}
 termStyle StopTerm      = style {color: "red", textDecoration : "line-through"}