Add test to show hierarchical level-2 grouping

test/Test/API/UpdateList.hs

@@ -31,19 +31,20 @@ import Control.Lens (mapped, over)
 import Control.Monad.Fail (fail)
 import Data.Aeson qualified as JSON
 import Data.Aeson.QQ
-import Data.Map.Strict.Patch qualified as PM
 import Data.Map.Strict qualified as Map
+import Data.Map.Strict.Patch qualified as PM
+import Data.Patch.Class
 import Data.Set qualified as Set
-import Data.Text.IO qualified as TIO
 import Data.Text qualified as T
+import Data.Text.IO qualified as TIO
 import Fmt
 import Gargantext.API.Admin.Auth.Types (Token)
 import Gargantext.API.Errors
 import Gargantext.API.HashedResponse
+import Gargantext.API.Ngrams qualified as APINgrams
 import Gargantext.API.Ngrams.List ( ngramsListFromTSVData )
 import Gargantext.API.Ngrams.List.Types (WithJsonFile(..), WithTextFile(..))
-import Gargantext.API.Ngrams qualified as APINgrams
-import Gargantext.API.Ngrams.Types
+import Gargantext.API.Ngrams.Types as NT
 import Gargantext.API.Node.Corpus.New.Types qualified as FType
 import Gargantext.API.Node.Types
 import Gargantext.API.Routes.Named
@@ -51,8 +52,8 @@ import Gargantext.API.Routes.Named.Corpus (addWithTempFileEp)
 import Gargantext.API.Routes.Named.Node
 import Gargantext.API.Routes.Named.Private
 import Gargantext.API.Worker (workerAPIPost)
-import Gargantext.Core.Config
 import Gargantext.Core qualified as Lang
+import Gargantext.Core.Config
 import Gargantext.Core.Text.Corpus.Query (RawQuery(..))
 import Gargantext.Core.Text.List.Social
 import Gargantext.Core.Text.Ngrams
@@ -64,7 +65,6 @@ import Gargantext.Database.Query.Facet qualified as Facet
 import Gargantext.Prelude hiding (get)
 import Network.Wai.Handler.Warp qualified as Wai
 import Paths_gargantext (getDataFileName)
-import qualified Prelude
 import Servant.Client.Streaming
 import System.FilePath
 import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser, alice)
@@ -77,6 +77,7 @@ import Test.Hspec.Wai.JSON (json)
 import Test.Types (JobPollHandle(..))
 import Test.Utils (pollUntilWorkFinished, protectedJSON, withValidLogin, isJobFinished)
 import Text.Printf (printf)
+import qualified Prelude
 
 
 uploadJSONList :: LogConfig
@@ -141,6 +142,91 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
                                                        ]
                                                    } |]
 
+      it "does allow creating hierarchical grouping at least for level-2" $ \(SpecContext testEnv port app _) -> do
+        cId <- newCorpusForUser testEnv "alice"
+        withApplication app $ do
+          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
+            ([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
+            let newMapTerm = NgramsRepoElement {
+                             _nre_size = 1
+                           , _nre_list        = MapTerm
+                           , _nre_root        = Nothing
+                           , _nre_parent      = Nothing
+                           , _nre_children    = mempty
+                           }
+            let add_guitar_pedals =
+                  PM.fromList [
+                    ( "guitar pedals"
+                    , NgramsReplace { _patch_old = Nothing
+                                    , _patch_new = Just newMapTerm })
+                    ]
+            _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst add_guitar_pedals)) clientEnv
+            let add_tube_screamers =
+                  PM.fromList [
+                    ( "tube screamers"
+                    , NgramsReplace { _patch_old = Nothing
+                                    , _patch_new = Just newMapTerm })
+                    ]
+            _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst add_tube_screamers)) clientEnv
+            let group_nodes =
+                  PM.fromList [
+                    ( "guitar pedals"
+                    , NgramsPatch { _patch_children = NT.PatchMSet (fst $ PM.fromList [("tube screamers", addPatch)])
+                                  , _patch_list = Keep })
+                    ]
+            _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst group_nodes)) clientEnv
+            -- Creates the grouping:
+            {- overdrives
+               |
+               \ guitar pedals
+                 |
+                 \ tube screamers
+            -}
+            let add_overdrives =
+                  PM.fromList [
+                    ( "overdrives"
+                    , NgramsReplace { _patch_old = Nothing
+                                    , _patch_new = Just newMapTerm })
+                    ]
+            _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst add_overdrives)) clientEnv
+            let group_nodes_2 =
+                  PM.fromList [
+                    ( "overdrives"
+                    , NgramsPatch { _patch_children = NT.PatchMSet (fst $ PM.fromList [("guitar pedals", addPatch)])
+                                  , _patch_list = Keep })
+                    ]
+            _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst group_nodes_2)) clientEnv
+            liftIO $ do
+              eRes <- runClientM (get_table_ngrams token cId APINgrams.Terms listId 50 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
+              eRes `shouldSatisfy` isRight
+              let (Right res) = eRes
+              Just res `shouldBe` JSON.decode [json| {"version":5
+                                                     ,"count":3
+                                                     ,"data":[
+                                                       {"ngrams":"guitar pedals"
+                                                       ,"size":1
+                                                       ,"list":"MapTerm"
+                                                       ,"root":"overdrives"
+                                                       ,"parent":"overdrives"
+                                                       ,"occurrences":[]
+                                                       ,"children":["tube screamers"]
+                                                       },
+                                                       {"ngrams":"overdrives"
+                                                       ,"size":1
+                                                       ,"list":"MapTerm"
+                                                       ,"occurrences":[]
+                                                       ,"children":["guitar pedals"]
+                                                       },
+                                                       {"ngrams":"tube screamers"
+                                                       ,"size":1
+                                                       ,"list":"MapTerm"
+                                                       ,"root":"overdrives"
+                                                       ,"parent":"guitar pedals"
+                                                       ,"occurrences":[]
+                                                       ,"children":[]}
+                                                       ]
+                                                     } |]
+
       it "does not create duplicates when uploading JSON (#313)" $ \(SpecContext testEnv port app _) -> do
         cId <- newCorpusForUser testEnv "alice"
         let log_cfg = (test_config testEnv) ^. gc_logging