[Feature] Add subcorpus creation functionality and modal integration

src/Gargantext/Components/DocsTable.purs

@@ -3,11 +3,12 @@ module Gargantext.Components.DocsTable where
 
 import Gargantext.Prelude
 
+import CSS (query)
 import DOM.Simple.Event as DE
-import Data.Array (any)
 import Data.Array as A
+import Data.Either (Either(..))
 import Data.Generic.Rep (class Generic)
-import Data.Lens ((^.))
+import Data.Lens (is, re, (^.))
 import Data.Lens.At (at)
 import Data.Lens.Record (prop)
 import Data.Map as Map
@@ -20,32 +21,30 @@ import Data.String as Str
 import Data.Tuple (Tuple(..))
 import Data.Tuple.Nested ((/\))
 import Effect (Effect)
-import Effect.Aff (Aff, launchAff_)
+import Effect.Aff (launchAff_)
 import Effect.Class (liftEffect)
-import Effect.Timer (setTimeout)
-import Gargantext.AsyncTasks as GAT
 import Gargantext.Components.App.Store as Store
 import Gargantext.Components.Bootstrap as B
-import Gargantext.Components.Bootstrap.Types (ComponentStatus(..), ModalSizing(..), Variant(..))
+import Gargantext.Components.Bootstrap.Types (ButtonVariant(..), ComponentStatus(..), ModalSizing(..), Variant(..))
 import Gargantext.Components.Category (ratingSimple)
 import Gargantext.Components.Category.Types (Category(..), cat2score, markCategoryChecked)
 import Gargantext.Components.DocsTable.DocumentFormCreation as DFC
-import Gargantext.Components.DocsTable.Types (DocumentsView(..), Hyperdata(..), LocalCategories, Query, Response(..), Year, sampleData, showSource)
+import Gargantext.Components.DocsTable.SubcorpusCreation (subcorpusCreation)
+import Gargantext.Components.DocsTable.Types (DocumentsView(..), Hyperdata(..), LocalCategories, Query, Response(..), SubcorpusParams(..), Year, createSubCorpus, sampleData, showSource)
 import Gargantext.Components.GraphQL.Endpoints (updateNodeContextCategory)
+import Gargantext.Components.Modal (modal)
 import Gargantext.Components.Nodes.Lists.Types as NT
 import Gargantext.Components.Reload (textsReloadContext)
 import Gargantext.Components.Table as TT
 import Gargantext.Components.Table.Types as TT
 import Gargantext.Config.REST (AffRESTError)
-import Gargantext.Config.Utils (handleRESTError)
 import Gargantext.Ends (Frontends, url)
 import Gargantext.Hooks.LinkHandler (useLinkHandler)
 import Gargantext.Hooks.Loader (useLoader, useLoaderWithCacheAPI, HashedResponse(..))
-import Gargantext.Routes (SessionRoute(NodeAPI))
+import Gargantext.Routes (SessionRoute(..))
 import Gargantext.Routes as Routes
-import Gargantext.Sessions (Session, sessionId, get, delete)
+import Gargantext.Sessions (Session, delete, get, sessionId)
 import Gargantext.Types (ListId, NodeID, NodeType(..), OrderBy(..), SidePanelState(..), TabSubType, TabType, TableResult, showTabType')
-import Gargantext.Types as GT
 import Gargantext.Utils (sortWith, (?))
 import Gargantext.Utils.CacheAPI as GUC
 import Gargantext.Utils.QueryString (joinQueryStrings, mQueryParamS, mQueryParamS', queryParam, queryParamS)
@@ -140,12 +139,16 @@ docViewCpt = R2.hereComponent here "docView" hCpt where
           , query
           } _ = do
     -- State
-    { errors } <- Store.use
+    { errors, reloadForest } <- Store.use
     cacheState' <- T.useLive T.unequal cacheState
     query' <- T.useLive T.unequal query
     isDocumentModalVisibleBox <- T.useBox false
+    isSubcorpusModalVisibleBox <- T.useBox false
     onDocumentCreationPending /\ onDocumentCreationPendingBox <-
       R2.useBox' false
+    reuseParentList' /\ reuseParentList <- R2.useBox' true
+    onSubcorpusCreationPending' /\ onSubcorpusCreationPending <- R2.useBox' false
+    { goToRoute } <- useLinkHandler
 
     -- Context
     mReloadContext <- R.useContext textsReloadContext
@@ -174,6 +177,20 @@ docViewCpt = R2.hereComponent here "docView" hCpt where
 
       liftEffect $ here.log "[docView] TODO onCreateDocumentEnd handler"
 
+    createSubcorpusCallback <- pure $ \q p -> launchAff_ do
+
+      liftEffect $
+        T.write_ true onSubcorpusCreationPending
+
+      res <- createSubCorpus session (fromMaybe 0 mCorpusId) $ SubcorpusParams { query: q, reuseParentList: p }
+      liftEffect $ do
+        case res of
+          Left err -> here.warn2 "[docsTable subSorpusButton RESTError]" err
+          Right id -> do 
+            T2.reload reloadForest
+            goToRoute $ Routes.Corpus (sessionId session) id
+
+
       -- handleRESTError hp errors eTask
       --   \t -> liftEffect $ launchDocumentCreationProgress
       --                         errors
@@ -202,7 +219,7 @@ docViewCpt = R2.hereComponent here "docView" hCpt where
               ]
             ]
           , H.div { className: "form-group" }
-            [ if showSearch then searchBar { query } [] else H.div {} [] ]
+            [ if showSearch then searchBar { query, isSubcorpusModalVisibleBox } [] else H.div {} [] ]
           ]
 
         , R2.row
@@ -238,6 +255,23 @@ docViewCpt = R2.hereComponent here "docView" hCpt where
           , status: onDocumentCreationPending ? Deferred $ Enabled
           }
         ]
+      ,
+        -- Subcorpus Creation Modal
+        B.baseModal
+        { isVisibleBox: isSubcorpusModalVisibleBox
+        , title: Just "Create a subcorpus"
+        , hasCollapsibleBackground: false
+        , size: MediumModalSize
+        }
+        [ 
+          subcorpusCreation
+          { callback: createSubcorpusCallback
+          , query'
+          , reuseParentList
+          , reuseParentList'
+          , onSubcorpusCreationPending'
+          }
+        ] 
       ]
 
 -- launchDocumentCreationProgress ::
@@ -282,39 +316,45 @@ docViewCpt = R2.hereComponent here "docView" hCpt where
 ---------------------------------------------------
 
 type SearchBarProps =
-  ( query :: T.Box Query )
+  ( query :: T.Box Query, isSubcorpusModalVisibleBox :: T.Box Boolean )
 
 searchBar :: R2.Component SearchBarProps
 searchBar = R.createElement searchBarCpt
 searchBarCpt :: R.Component SearchBarProps
 searchBarCpt = here.component "searchBar" cpt
   where
-    cpt { query } _children = do
+    cpt { query, isSubcorpusModalVisibleBox} _children = do
       query' <- T.useLive T.unequal query
       queryText <- T.useBox query'
       queryText' <- T.useLive T.unequal queryText
 
-      pure $ H.div {className: "input-group px-5"}
-        [ H.input { className: "form-control"
-                    , id: "docs-input-search"
-                    , defaultValue: query'
-                    , on: { change: onSearchChange queryText
-                          , keyUp: onSearchKeyup query queryText' }
-                    , placeholder: "Search in documents"
-                    , type: "text" }
-        , H.div {className: "input-group-append"}
-          [
-            if query' /= ""
-            then
-              R.fragment
-                [ clearButton query
-                , searchButton query queryText'
+      pure $ R.fragment [
+        H.div {className: "input-group px-5"}
+          [ H.input { className: "form-control"
+                      , id: "docs-input-search"
+                      , defaultValue: query'
+                      , on: { change: onSearchChange queryText
+                            , keyUp: onSearchKeyup query queryText' }
+                      , placeholder: "Search in documents"
+                      , type: "text" }
+          , H.div {className: "input-group-append"}
+            [
+              if query' /= ""
+              then
+                R.fragment
+                  [ clearButton query
+                  , searchButton query queryText'
+                  , subCorpusButton isSubcorpusModalVisibleBox queryText' query
+                  ]
+              else
+                R.fragment
+                [ searchButton query queryText'
+                , subCorpusButton isSubcorpusModalVisibleBox queryText' query
                 ]
-            else
-              searchButton query queryText'
-          ]
-        -- , H.div {className: "col-md-1"} [ searchButton query queryText' ]
+            ]
+          -- , H.div {className: "col-md-1"} [ searchButton query queryText' ]
         ]
+      ]
 
     onSearchChange :: forall e. T.Box Query -> e -> Effect Unit
     onSearchChange queryText e =
@@ -338,6 +378,14 @@ searchBarCpt = here.component "searchBar" cpt
                , on: { click: \_ -> T.write_ "" query } }
         [ H.span {className: "text-danger fa fa-times"} [] ]
 
+    subCorpusButton modalVisible queryText' query =
+      H.button { className: "input-group-text btn btn-light text-secondary"
+               , on: { click: \_ -> do 
+                         T.write_ queryText' query
+                         T.write_ true modalVisible }
+               , type: "submit" }
+        [ H.span {className: "fa fa-filter"} [] ]
+
 mock :: Boolean
 mock = false
 

src/Gargantext/Components/DocsTable/SubcorpusCreation.purs

+module Gargantext.Components.DocsTable.SubcorpusCreation where
+
+import Gargantext.Prelude
+
+import Effect (Effect)
+import Gargantext.Components.Bootstrap as B
+import Gargantext.Components.Bootstrap.Types (ButtonVariant(..), ComponentStatus(..), Variant(..))
+import Gargantext.Utils.Reactix as R2
+import Reactix as R
+import Reactix.DOM.HTML as H
+import Toestand as T
+
+type Props =
+  ( callback  :: String -> Boolean -> Effect Unit
+  , query'    :: String
+  , reuseParentList :: T.Box Boolean
+  , reuseParentList' :: Boolean
+  , onSubcorpusCreationPending' :: Boolean
+  )
+
+subcorpusCreation :: R2.Leaf Props
+subcorpusCreation = R2.leaf component
+
+component :: R.Component Props
+component = R.hooksComponent "subcorpusCreation" cpt where
+  cpt {query', reuseParentList, reuseParentList', onSubcorpusCreationPending', callback} _ = do
+    pure $ H.div {} [
+            H.div {className: "form-group"} [
+              H.label {} [ H.text $ "Creating subcorpus from query: " <> query' ]
+            ]
+            ,
+            H.div {className: "form-check" } [
+              B.formCheckbox
+              { value: reuseParentList'
+              , callback: \_ -> T.modify_ not reuseParentList
+              }
+            , H.label { className: "form-check-label"} [H.text "Reuse parent list?"]
+            ]
+            ,
+            B.button 
+            { callback: \_ -> callback query' reuseParentList'
+            , type: "submit"
+            , variant: ButtonVariant Primary
+            , status: if query' == "" then Disabled else if onSubcorpusCreationPending' then Deferred else Enabled
+            }
+            [ H.text "Create!"]
+      ]

src/Gargantext/Components/DocsTable/Types.purs

 module Gargantext.Components.DocsTable.Types where
 
+import Gargantext.Prelude
+
 import Data.Eq.Generic (genericEq)
 import Data.Generic.Rep (class Generic)
 import Data.Map (Map)
 import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Tuple (Tuple(..))
 import Gargantext.Components.Category.Types (Category(..), Star, decodeCategory)
-import Gargantext.Prelude
+import Gargantext.Config.REST (AffRESTError)
+import Gargantext.Routes (SessionRoute(..))
+import Gargantext.Sessions (Session, post)
+import Gargantext.Types (NodeID)
 import Simple.JSON as JSON
 
 data Action
@@ -101,6 +106,18 @@ type LocalUserScore  = Map Int Star
 type Query = String
 type Year = String
 
+newtype SubcorpusParams = SubcorpusParams
+  { query :: Query
+  , reuseParentList :: Boolean
+  }
+derive instance Eq SubcorpusParams
+derive instance Generic SubcorpusParams _
+derive newtype instance JSON.ReadForeign SubcorpusParams
+derive newtype instance JSON.WriteForeign SubcorpusParams
+
+createSubCorpus :: Session -> Int -> SubcorpusParams -> AffRESTError NodeID
+createSubCorpus session parentId = post session (SubCorpus parentId)
+
 ---------------------------------------------------------
 sampleData' :: DocumentsView
 sampleData' = DocumentsView { _id : 1

src/Gargantext/Ends.purs

@@ -218,6 +218,7 @@ sessionPath (R.ChartHash { chartType, listId, tabType } i) =
 sessionPath (R.PhyloAPI nId) = "node/" <> show nId <> "/phylo"
 sessionPath R.Members = "members"
 sessionPath (R.ShareURL i t) = "shareurl?type=" <> show t <> "&id=" <> show i
+sessionPath (R.SubCorpus i) = "corpus/" <> show i <> "/subcorpus"
 
 ------- misc routing stuff
 

src/Gargantext/Routes.purs

@@ -151,6 +151,7 @@ data SessionRoute
   | PhyloAPI Id
   | Members
   | ShareURL Id NodeType
+  | SubCorpus Id
 
 
 ------------------------------------------------------