Merge branch 'dev' into dev-doc-table-score

bin/gargantext-import/Main.hs

@@ -29,7 +29,6 @@ import Gargantext.API.Prelude (GargError)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Action.Flow (FlowCmdM, flowCorpusFile, flowAnnuaire, TermType(..))
-import Gargantext.Database.Query.Table.User (insertUsersDemo)
 import Gargantext.Database.Admin.Types.Hyperdata (toHyperdataDocument)
 import Gargantext.Database.Admin.Types.Node (CorpusId)
 import Gargantext.Database.Prelude (Cmd)
@@ -42,9 +41,6 @@ main = do
 
   --{-
 
-  let createUsers :: Cmd GargError Int64
-      createUsers = insertUsersDemo
-  
   let
     --tt = (Unsupervised EN 6 0 Nothing)
     tt = (Multi EN)
@@ -70,10 +66,6 @@ main = do
   --}
 
   withDevEnv iniPath $ \env -> do
-    _ <- if fun == "users"
-          then runCmdDev env createUsers
-          else pure 0 --(cs "false")
-
     _ <- if fun == "corpus"
           then runCmdDev env corpus
           else pure 0 --(cs "false")

bin/gargantext-init/Main.hs

@@ -20,10 +20,10 @@ import Data.Either (Either(..))
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Prelude (GargError)
 import Gargantext.API.Node () -- instances only
-import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..))
 import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMk_RootWithCorpus)
 import Gargantext.Database.Query.Table.Node (getOrMkList)
-import Gargantext.Database.Query.Table.User (insertUsersDemo)
+import Gargantext.Database.Query.Table.User (insertNewUsers, )
 import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
@@ -31,6 +31,7 @@ import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
 import Gargantext.Database.Prelude (Cmd, )
 import Gargantext.Prelude
 import System.Environment (getArgs)
+import Prelude (getLine)
 
 -- TODO put this in gargantext.ini
 secret :: Text
@@ -40,12 +41,21 @@ main :: IO ()
 main = do
   [iniPath] <- getArgs
 
+  putStrLn "Enter master user (gargantua) _password_ :"
+  password  <- getLine
+
+  putStrLn "Enter master user (gargantua) _email_ :"
+  email     <- getLine
+
+
   let createUsers :: Cmd GargError Int64
-      createUsers = insertUsersDemo
+      createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)
+                                   : arbitraryNewUsers
+                                   )
 
   let
     mkRoots :: Cmd GargError [(UserId, RootId)]
-    mkRoots = mapM getOrMkRoot $ map UserName ["gargantua", "user1", "user2", "user3"]
+    mkRoots = mapM getOrMkRoot $ map UserName ("gargantua" : arbitraryUsername)
     -- TODO create all users roots
 
   let

package.yaml

 name: gargantext
-version: '0.0.1.94.1'
+version: '0.0.2.0'
 synopsis: Search, map, share
 description: Please see README.md
 category: Data

src/Gargantext/API/Metrics.hs

@@ -25,7 +25,7 @@ import Data.Time (UTCTime)
 import Servant
 
 import Gargantext.API.HashedResponse
-import Gargantext.API.Ngrams.NTree
+import Gargantext.API.Ngrams.NgramsTree
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Prelude (GargServer)
 import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
@@ -317,7 +317,7 @@ type TreeApi = Summary " Tree API"
            :> QueryParam  "list"       ListId
            :> QueryParamR "ngramsType" TabType
            :> QueryParamR "listType"   ListType
-           :> Get '[JSON] (HashedResponse (ChartMetrics [MyTree]))
+           :> Get '[JSON] (HashedResponse (ChartMetrics [NgramsTree]))
         :<|> Summary "Tree Chart update"
                 :> QueryParam  "list"       ListId
                 :> QueryParamR "ngramsType" TabType
@@ -347,7 +347,7 @@ getTree :: FlowCmdM env err m
         -> Maybe ListId
         -> TabType
         -> ListType
-        -> m (HashedResponse (ChartMetrics [MyTree]))
+        -> m (HashedResponse (ChartMetrics [NgramsTree]))
 getTree cId _start _end maybeListId tabType listType = do
   listId <- case maybeListId of
     Just lid -> pure lid
@@ -383,7 +383,7 @@ updateTree' :: FlowCmdM env err m =>
   -> Maybe ListId
   -> TabType
   -> ListType
-  -> m (ChartMetrics [MyTree])
+  -> m (ChartMetrics [NgramsTree])
 updateTree' cId maybeListId tabType listType = do
   listId <- case maybeListId of
     Just lid -> pure lid

src/Gargantext/API/Ngrams.hs

-{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 {-|
 Module      : Gargantext.API.Ngrams
 Description : Server API
@@ -16,6 +15,8 @@ add get
 
 -}
 
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
 {-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators     #-}
@@ -307,6 +308,10 @@ commitStatePatch (Versioned p_version p) = do
     pure (r', Versioned (r' ^. r_version) q')
 
   saveRepo
+
+  -- Save new ngrams
+  _ <- insertNgrams (newNgramsFromNgramsStatePatch p)
+
   pure vq'
 
 -- This is a special case of tableNgramsPut where the input patch is empty.

src/Gargantext/API/Ngrams/NTree.hs → src/Gargantext/API/Ngrams/NgramsTree.hs

 {-|
-Module      : Gargantext.API.Ngrams.NTree
+Module      : Gargantext.API.Ngrams.NgramsTree
 Description : Tree of Ngrams
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3
@@ -11,7 +11,7 @@ Portability : POSIX
 
 {-# LANGUAGE TemplateHaskell   #-}
 
-module Gargantext.API.Ngrams.NTree
+module Gargantext.API.Ngrams.NgramsTree
   where
 
 import Data.Aeson.TH (deriveJSON)
@@ -36,24 +36,25 @@ import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 type Children = Text
 type Root = Text
 
-data MyTree = MyTree { mt_label :: Text
-                     , mt_value :: Double
-                     , mt_children :: [MyTree]
-                  } deriving (Generic, Show)
+data NgramsTree = NgramsTree { mt_label :: Text
+                             , mt_value :: Double
+                             , mt_children :: [NgramsTree]
+                             }
+    deriving (Generic, Show)
 
-toMyTree :: Tree (Text,Double) -> MyTree
-toMyTree (Node (l,v) xs) = MyTree l v (map toMyTree xs)
+toNgramsTree :: Tree (Text,Double) -> NgramsTree
+toNgramsTree (Node (l,v) xs) = NgramsTree l v (map toNgramsTree xs)
 
-deriveJSON (unPrefix "mt_") ''MyTree
+deriveJSON (unPrefix "mt_") ''NgramsTree
 
-instance ToSchema MyTree where
+instance ToSchema NgramsTree where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
-instance Arbitrary MyTree
+instance Arbitrary NgramsTree
   where
-    arbitrary = MyTree <$> arbitrary <*> arbitrary <*> arbitrary
+    arbitrary = NgramsTree <$> arbitrary <*> arbitrary <*> arbitrary
 
-toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [MyTree]
-toTree lt vs m = map toMyTree $ unfoldForest buildNode roots
+toTree :: ListType -> Map Text (Set NodeId) -> Map Text NgramsRepoElement -> [NgramsTree]
+toTree lt vs m = map toNgramsTree $ unfoldForest buildNode roots
   where
     buildNode r = maybe ((r, value r),[])
                         (\x -> ((r, value r), unNgramsTerm <$> (mSetToList $ _nre_children x)))

src/Gargantext/API/Ngrams/Types.hs

@@ -50,7 +50,7 @@ import Gargantext.Core.Text (size)
 import Gargantext.Core.Types (ListType(..), ListId, NodeId)
 import Gargantext.Core.Types (TODO)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger, wellNamedSchema)
-import Gargantext.Database.Prelude (fromField', CmdM')
+import Gargantext.Database.Prelude (fromField', CmdM', HasConnectionPool, HasConfig)
 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 
 ------------------------------------------------------------------------
@@ -706,8 +706,10 @@ instance HasRepoSaver RepoEnv where
   repoSaver = renv_saver
 
 type RepoCmdM   env err m =
-  ( CmdM' env err m
-  , HasRepo     env
+  ( CmdM'             env err m
+  , HasRepo           env
+  , HasConnectionPool env
+  , HasConfig         env
   )
 
 

src/Gargantext/API/Node.hs

@@ -210,10 +210,10 @@ nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode
            -- TODO gather it
            :<|> tableApi             id'
            :<|> apiNgramsTableCorpus id'
-            
+
            :<|> catApi      id'
            :<|> Search.api  id'
-           :<|> Share.api   id'
+           :<|> Share.api   (RootId $ NodeId uId) id'
            -- Pairing Tools
            :<|> pairWith    id'
            :<|> pairs       id'

src/Gargantext/API/Node/Share.hs

@@ -19,18 +19,21 @@ import Data.Aeson
 import Data.Swagger
 import Data.Text (Text)
 import GHC.Generics (Generic)
-import Servant
-import Test.QuickCheck (elements)
-import Test.QuickCheck.Arbitrary
-
 import Gargantext.API.Prelude
-import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Core.Types.Individu (User(..), arbitraryUsername)
 import Gargantext.Database.Action.Share (ShareNodeWith(..))
 import Gargantext.Database.Action.Share as DB (shareNodeWith, unPublish)
+import Gargantext.Database.Action.User
+import Gargantext.Database.Action.User.New
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude
+import Gargantext.Database.Query.Tree (findNodesId)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Prelude
+import Servant
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary
+import qualified Data.List as List
 
 ------------------------------------------------------------------------
 data ShareNodeParams = ShareTeamParams   { username :: Text  }
@@ -49,13 +52,43 @@ instance Arbitrary ShareNodeParams where
                        ]
 ------------------------------------------------------------------------
 -- TODO permission
+-- TODO refactor userId which is used twice
+-- TODO change return type for better warning/info/success/error handling on the front
 api :: HasNodeError err
-    => NodeId
+    => User
+    -> NodeId
     -> ShareNodeParams
-    -> Cmd err Int
-api nId (ShareTeamParams user) =
-  fromIntegral <$> DB.shareNodeWith (ShareNodeWith_User NodeFolderShared (UserName user)) nId 
-api nId2 (SharePublicParams nId1) =
+    -> CmdR err Int
+api userInviting nId (ShareTeamParams user') = do
+  user <- case guessUserName user' of
+    Nothing    -> pure user'
+    Just (u,_) -> do
+      isRegistered <- getUserId' (UserName u)
+      case isRegistered of
+        Just _  -> do
+          printDebug "[G.A.N.Share.api]" ("Team shared with " <> u)
+          pure u
+        Nothing -> do
+          username' <- getUsername userInviting
+          _ <- case List.elem username' arbitraryUsername of
+            True  -> do
+              printDebug "[G.A.N.Share.api]" ("demo users are not allowed to invite" :: Text)
+              pure ()
+            False -> do
+              children <- findNodesId nId [NodeCorpus]
+              _ <- case List.null children of
+                True -> do
+                  printDebug "[G.A.N.Share.api]" ("Invitation is enabled if you share a corpus at least" :: Text)
+                  pure 0
+                False -> do 
+                  printDebug "[G.A.N.Share.api]" ("Your invitation is sent to: " <> user')
+                  newUsers [user']
+              pure ()
+          pure u
+
+  fromIntegral <$> DB.shareNodeWith (ShareNodeWith_User NodeFolderShared (UserName user)) nId
+api _uId nId2 (SharePublicParams nId1) =
+
   fromIntegral <$> DB.shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId1) nId2
 
 ------------------------------------------------------------------------

src/Gargantext/API/Prelude.hs

@@ -68,7 +68,7 @@ type ErrC err =
   )
 
 type GargServerC env err m =
-  ( CmdM' env err m
+  ( CmdRandom env err m
   , EnvC  env
   , ErrC      err
   )

src/Gargantext/Core/Text/List/Group.hs

@@ -13,94 +13,67 @@ Portability : POSIX
 {-# LANGUAGE ConstraintKinds        #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE FunctionalDependencies #-}
-
+{-# LANGUAGE InstanceSigs           #-}
 
 module Gargantext.Core.Text.List.Group
   where
 
-import Control.Lens (set)
-import Data.Set (Set)
+import Control.Lens (view)
 import Data.Map (Map)
+import Data.Maybe (fromMaybe)
+import Data.Monoid (Monoid, mempty)
 import Data.Text (Text)
-import Gargantext.Core.Types (ListType(..))
-import Gargantext.Database.Admin.Types.Node (NodeId)
-import Gargantext.Core.Text.List.Social.Scores (FlowListScores(..))
+import Gargantext.Core.Text.List.Social.Prelude
+import Gargantext.Core.Text.List.Group.Prelude
 import Gargantext.Core.Text.List.Group.WithStem
 import Gargantext.Core.Text.List.Group.WithScores
 import Gargantext.Prelude
-import qualified Data.Set  as Set
 import qualified Data.Map  as Map
-import qualified Data.List as List
 
 ------------------------------------------------------------------------
-toGroupedText :: GroupedTextParams a b
-              -> Map Text FlowListScores
-              -> Map Text (Set NodeId)
-              -> Map Stem (GroupedText Int)
-toGroupedText groupParams scores =
-  (groupWithStem groupParams) . (groupWithScores scores)
-
-
-------------------------------------------------------------------------
--- | WIP
-toGroupedText_test :: Bool -- Map Stem (GroupedText Int)
-toGroupedText_test =
-  -- fromGroupedScores $ fromListScores from
-  toGroupedText params from datas == result
+-- | TODO add group with stemming
+toGroupedTree :: (Ord a, Monoid a, GroupWithStem a)
+              => GroupParams
+              -> FlowCont Text FlowListScores
+              -> Map Text a
+             -- -> Map Text (GroupedTreeScores (Set NodeId))
+              -> FlowCont Text (GroupedTreeScores a)
+toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
     where
-      params = GroupedTextParams identity (Set.size . snd) fst snd
-      from :: Map Text FlowListScores
-      from = Map.fromList [("A. Rahmani",FlowListScores {_fls_parents = Map.fromList [("T. Reposeur",1)]
-                                                        ,_fls_listType = Map.fromList [(MapTerm,2)]})
-                           ,("B. Tamain",FlowListScores {_fls_parents = Map.fromList [("T. Reposeur",1)]
-                                                        , _fls_listType = Map.fromList [(MapTerm,2)]})
-                           ]
+      flow1     = groupWithScores' flc scoring
+      scoring t = fromMaybe mempty $ Map.lookup t scores
 
-      datas :: Map Text (Set NodeId)
-      datas = Map.fromList [("A. Rahmani" , Set.fromList [1,2])
-                           ,("T. Reposeur", Set.fromList [3,4])
-                           ,("B. Tamain"  , Set.fromList [5,6])
-                           ]
+      flow2 = case (view flc_cont flow1) == Map.empty of
+        True  -> flow1
+        False -> groupWithStem' groupParams flow1
 
 
-      result :: Map Stem (GroupedText Int)
-      result = Map.fromList [("A. Rahmani",GroupedText {_gt_listType = Nothing
-                                                       ,_gt_label = "A. Rahmani"
-                                                       ,_gt_score = 2
-                                                       ,_gt_children = Set.empty
-                                                       ,_gt_size = 2
-                                                       ,_gt_stem = "A. Rahmani"
-                                                       ,_gt_nodes = Set.fromList [1,2]
-                                                       }
-                              )
-                            ,("B. Tamain",GroupedText {_gt_listType = Nothing
-                                                      , _gt_label = "B. Tamain"
-                                                      , _gt_score = 2
-                                                      , _gt_children = Set.empty
-                                                      , _gt_size = 2
-                                                      , _gt_stem = "B. Tamain"
-                                                      , _gt_nodes = Set.fromList [5,6]
-                                                      }
-                              )
-                            ,("T. Reposeur",GroupedText {_gt_listType = Nothing
-                                                        ,_gt_label = "T. Reposeur"
-                                                        ,_gt_score = 2
-                                                        ,_gt_children = Set.fromList ["A. Rahmani","B. Tamain"]
-                                                        ,_gt_size = 2
-                                                        ,_gt_stem = "T. Reposeur"
-                                                        ,_gt_nodes = Set.fromList [1..6]
-                                                        }
-                            )
-                           ]
 
 ------------------------------------------------------------------------
--- | To be removed
-addListType :: Map Text ListType -> GroupedText a -> GroupedText a
-addListType m g = set gt_listType (hasListType m g) g
+setScoresWithMap :: (Ord a, Ord b, Monoid b) => Map Text b
+                 -> Map Text (GroupedTreeScores a)
+                 -> Map Text (GroupedTreeScores b)
+setScoresWithMap m = setScoresWith (score m)
   where
-    hasListType :: Map Text ListType -> GroupedText a -> Maybe ListType
-    hasListType m' (GroupedText _ label _ g' _ _ _) =
-        List.foldl' (<>) Nothing
-      $ map (\t -> Map.lookup t m')
-      $ Set.toList
-      $ Set.insert label g'
+    score m' t = case Map.lookup t m' of
+      Nothing -> mempty
+      Just  r -> r
+
+setScoresWith :: (Ord a, Ord b)
+              => (Text -> b)
+              -> Map Text (GroupedTreeScores a)
+              -> Map Text (GroupedTreeScores b)
+{-
+-- | This Type level lenses solution does not work
+setScoresWith f = Map.mapWithKey (\k v -> over gts'_children (setScoresWith f)
+                                       $  set  gts'_score    (f k) v
+                                 )
+-}
+setScoresWith f = Map.mapWithKey (\k v -> v { _gts'_score    = f k
+                                            , _gts'_children = setScoresWith f
+                                                             $ view gts'_children v
+                                            }
+                                 )
+
+
+------------------------------------------------------------------------

src/Gargantext/Core/Text/List/Group/Prelude.hs

+{-|
+Module      : Gargantext.Core.Text.List.Group.Prelude
+Description :
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE InstanceSigs           #-}
+
+module Gargantext.Core.Text.List.Group.Prelude
+  where
+
+import Control.Lens (makeLenses, view, set, over)
+import Data.Monoid
+import Data.Semigroup
+import Data.Set (Set)
+import Data.Text (Text)
+import Data.Maybe (fromMaybe)
+import Data.Map (Map)
+import Gargantext.Core.Types (ListType(..))
+import Gargantext.Database.Admin.Types.Node (NodeId)
+import Gargantext.Core.Text.Metrics (Scored(..), scored_genInc)
+import Gargantext.API.Ngrams.Types (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList)
+import Gargantext.Prelude
+import qualified Data.Set  as Set
+import qualified Data.Map  as Map
+import qualified Data.List as List
+
+type Stem = Text
+------------------------------------------------------------------------
+-- | Main Types to group With Scores but preserving Tree dependencies
+-- Therefore there is a need of Tree of GroupedTextScores
+-- to target continuation type for the flow (FlowCont Text GroupedTreeScores)
+data GroupedTreeScores score =
+  GroupedTreeScores { _gts'_listType :: !(Maybe ListType)
+                    , _gts'_children :: !(Map Text (GroupedTreeScores score))
+                    , _gts'_score    :: !score
+                    } deriving (Show, Ord, Eq)
+
+instance (Semigroup a) => Semigroup (GroupedTreeScores a) where
+  (<>) (GroupedTreeScores  l1 s1 c1)
+       (GroupedTreeScores  l2 s2 c2)
+      = GroupedTreeScores (l1 <> l2)
+                          (s1 <> s2)
+                          (c1 <> c2)
+
+instance (Ord score, Monoid score)
+  => Monoid (GroupedTreeScores score) where
+    mempty = GroupedTreeScores mempty mempty mempty
+
+makeLenses 'GroupedTreeScores
+
+------------------------------------------------------------------------
+-- | Main Classes
+class ViewListType a where
+  viewListType :: a -> Maybe ListType
+
+class SetListType a where
+  setListType :: Maybe ListType -> a -> a
+
+------
+class Ord b => ViewScore a b | a -> b where
+  viewScore :: a -> b
+
+class ViewScores a b | a -> b where
+  viewScores :: a -> b
+
+--------
+class ToNgramsElement a where
+  toNgramsElement :: a -> [NgramsElement]
+
+class HasTerms a where
+  hasTerms :: a -> Set Text
+
+------------------------------------------------------------------------
+-- | Instances declartion for (GroupedTreeScores a)
+instance ViewListType (GroupedTreeScores a) where
+  viewListType = view gts'_listType
+
+instance SetListType (GroupedTreeScores a) where
+  setListType lt g = over gts'_children (setListType lt)
+                $ set gts'_listType lt g
+
+instance SetListType (Map Text (GroupedTreeScores a)) where
+  setListType lt = Map.map (set gts'_listType lt)
+
+                            ------
+
+instance ViewScore (GroupedTreeScores Double) Double where
+  viewScore = viewScores
+
+instance ViewScores (GroupedTreeScores Double) Double where
+  viewScores g = sum $ parent : children
+    where
+      parent   = view gts'_score g
+      children = map viewScores $ Map.elems $ view gts'_children g
+
+
+instance ViewScore (GroupedTreeScores (Set NodeId)) Int where
+  viewScore = Set.size . viewScores
+
+instance ViewScores (GroupedTreeScores (Set NodeId)) (Set NodeId) where
+  viewScores g = Set.unions $ parent : children
+    where
+      parent   = view gts'_score g
+      children = map viewScores $ Map.elems $ view gts'_children g
+
+
+instance ViewScore (GroupedTreeScores (Scored Text)) Double where
+  viewScore = view (gts'_score . scored_genInc)
+
+                            ------
+instance HasTerms (Map Text (GroupedTreeScores a)) where
+  hasTerms = Set.unions . (map hasTerms) . Map.toList
+
+instance HasTerms (Text, GroupedTreeScores a) where
+  hasTerms (t, g) = Set.singleton t  <> children
+    where
+      children = Set.unions
+               $ map hasTerms
+               $ Map.toList
+               $ view gts'_children g
+
+                            ------
+
+instance ToNgramsElement (Map Text (GroupedTreeScores a)) where
+  toNgramsElement = List.concat . (map toNgramsElement) . Map.toList
+
+
+instance ToNgramsElement (Text, GroupedTreeScores a) where
+  toNgramsElement (t, gts) = parent : children
+    where
+      parent = mkNgramsElement (NgramsTerm t)
+                               (fromMaybe CandidateTerm $ viewListType gts)
+                               Nothing
+                               (mSetFromList $ map NgramsTerm
+                                             $ Map.keys
+                                             $ view gts'_children gts
+                               )
+      children = List.concat
+               $ map (childrenWith (NgramsTerm t) (NgramsTerm t) )
+               $ Map.toList
+               $ view gts'_children gts
+
+      childrenWith root parent' (t', gts') = parent'' : children'
+        where
+          parent''   = mkNgramsElement (NgramsTerm t')
+                                      (fromMaybe CandidateTerm $ viewListType gts')
+                                      (Just $ RootParent root parent')
+                                      (mSetFromList $ map NgramsTerm
+                                                    $ Map.keys
+                                                    $ view gts'_children gts'
+                                      )
+          children' = List.concat
+                    $ map (childrenWith root (NgramsTerm t') )
+                    $ Map.toList
+                    $ view gts'_children gts'
+
+

src/Gargantext/Core/Text/List/Group/WithScores.hs

@@ -10,116 +10,88 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE InstanceSigs           #-}
 
 module Gargantext.Core.Text.List.Group.WithScores
   where
 
-import Control.Lens (makeLenses, view, set)
+import Control.Lens (view, set, over)
 import Data.Semigroup
-import Data.Set (Set)
 import Data.Map (Map)
-import Data.Maybe (catMaybes)
+import Data.Monoid (Monoid, mempty)
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
-import Gargantext.Core.Types (ListType(..)) -- (MasterCorpusId, UserCorpusId)
-import Gargantext.Database.Admin.Types.Node (NodeId)
--- import Gargantext.Core.Text.List.Learn (Model(..))
-import Gargantext.Core.Text.List.Social.Scores
+import Gargantext.Core.Text.List.Social.Prelude
+import Gargantext.Core.Text.List.Group.Prelude
 import Gargantext.Prelude
-import qualified Data.Set  as Set
 import qualified Data.Map  as Map
 
 ------------------------------------------------------------------------
--- | Main Types
-data GroupedWithListScores =
-  GroupedWithListScores { _gwls_children :: !(Set Text)
-                        , _gwls_listType :: !(Maybe ListType)
-                        } deriving (Show)
-makeLenses ''GroupedWithListScores
-instance Semigroup GroupedWithListScores where
-  (<>) (GroupedWithListScores c1 l1)
-       (GroupedWithListScores c2 l2) = 
-        GroupedWithListScores (c1 <> c2) (l1 <> l2)
-
-------
-data GroupedTextScores score =
-  GroupedTextScores { _gts_listType :: !(Maybe ListType)
-                    , _gts_score    :: score
-                    , _gts_children :: !(Set Text)
-                    } deriving (Show)
-makeLenses 'GroupedTextScores
-instance Semigroup a => Semigroup (GroupedTextScores a) where
-  (<>) (GroupedTextScores l1 s1 c1)
-       (GroupedTextScores l2 s2 c2)
-    = GroupedTextScores (l1 <> l2) (s1 <> s2) (c1 <> c2)
-
-------
-data GroupedTextScores' score =
-  GroupedTextScores' { _gts'_listType :: !(Maybe ListType)
-                     , _gts'_score    :: score
-                     , _gts'_children :: !(Set (GroupedTextScores' score))
-                     } deriving (Show, Ord, Eq)
-makeLenses 'GroupedTextScores'
-instance (Semigroup a, Ord a) => Semigroup (GroupedTextScores' a) where
-  (<>) (GroupedTextScores' l1 s1 c1)
-       (GroupedTextScores' l2 s2 c2)
-    = GroupedTextScores' (l1 <> l2) (s1 <> s2) (c1 <> c2)
-
-
 ------------------------------------------------------------------------
 -- | Main function
-groupWithScores :: Map Text FlowListScores
-                -> Map Text (Set NodeId)
-                -> Map Text (GroupedTextScores (Set NodeId))
-groupWithScores scores ms = orphans <> groups
+groupWithScores' :: (Eq a, Ord a, Monoid a)
+                => FlowCont Text FlowListScores
+                -> (Text -> a) -- Map Text (a)
+                -> FlowCont Text (GroupedTreeScores (a))
+groupWithScores' flc scores = FlowCont  groups orphans
   where
-    groups = addScore ms
-           $ fromGroupedScores
-           $ fromListScores scores
-    orphans = addIfNotExist scores ms
+    -- parent/child relation is inherited from social lists
+    groups  = toGroupedTree
+            $ toMapMaybeParent scores
+            $ view flc_scores flc
+
+    -- orphans should be filtered already
+    orphans = toGroupedTree
+            $ toMapMaybeParent scores
+            $ view flc_cont flc
+------------------------------------------------------------------------
+toMapMaybeParent :: (Eq a, Ord a, Monoid a)
+                 => (Text -> a)
+                 -> Map Text FlowListScores
+                 -> Map (Maybe Parent) (Map Text (GroupedTreeScores (a)))
+toMapMaybeParent f =  Map.fromListWith (<>)
+                   . (map (fromScores'' f))
+                   .  Map.toList
+
+fromScores'' :: (Eq a, Ord a, Monoid a)
+             => (Text -> a)
+             -> (Text, FlowListScores)
+             -> (Maybe Parent, Map Text (GroupedTreeScores (a)))
+fromScores'' f' (t, fs) = ( maybeParent
+                          , Map.fromList [( t, set gts'_score (f' t)
+                                             $ set gts'_listType maybeList mempty
+                                         )]
+                          )
+    where
+     maybeParent = keyWithMaxValue $ view fls_parents  fs
+     maybeList   = keyWithMaxValue $ view fls_listType fs
+
+toGroupedTree :: Eq a
+              => Map (Maybe Parent) (Map Text (GroupedTreeScores (a)))
+              -> Map Parent (GroupedTreeScores (a))
+toGroupedTree m = case Map.lookup Nothing m of
+  Nothing  -> mempty
+  Just  m' -> toGroupedTree' m m'
+
+
+toGroupedTree' :: Eq a => Map (Maybe Parent) (Map Text (GroupedTreeScores (a)))
+               -> (Map Text (GroupedTreeScores (a)))
+               ->  Map Parent (GroupedTreeScores (a))
+toGroupedTree' m notEmpty
+  | notEmpty == mempty = mempty
+  | otherwise = Map.mapWithKey (addGroup m) notEmpty
+    where
+      addGroup m' k v = over gts'_children ( (toGroupedTree' m')
+                                           . (Map.union ( fromMaybe mempty
+                                                        $ Map.lookup (Just k) m'
+                                                        )
+                                             )
+                                           )
+                                           v
 
 
-addScore :: Map Text (Set NodeId)
-         -> Map Text (GroupedTextScores (Set NodeId))
-         -> Map Text (GroupedTextScores (Set NodeId))
-addScore mapNs = Map.mapWithKey scoring
-  where
 
-    scoring k g = set gts_score ( Set.unions
-                                $ catMaybes
-                                $ map (\n -> Map.lookup n mapNs)
-                                $ [k] <> (Set.toList $ view gts_children g)
-                                ) g
-
-addIfNotExist :: Map Text FlowListScores
-              -> Map Text (Set NodeId)
-              -> Map Text (GroupedTextScores (Set NodeId))
-addIfNotExist mapSocialScores mapScores =
-  foldl' (addIfNotExist' mapSocialScores) Map.empty $ Map.toList mapScores
-    where
-      addIfNotExist' mss m (t,ns) =
-        case Map.lookup t mss of
-          Nothing -> Map.alter (add ns) t m
-          _       -> m
-
-      add ns' Nothing = Just $ GroupedTextScores Nothing ns' Set.empty
-      add _ _            = Nothing -- should not be present
 
 
-------------------------------------------------------------------------
-fromGroupedScores :: Map Parent GroupedWithListScores
-                  -> Map Parent (GroupedTextScores (Set NodeId))
-fromGroupedScores = Map.map (\(GroupedWithListScores c l) -> GroupedTextScores l Set.empty c)
 
-------------------------------------------------------------------------
-fromListScores :: Map Text FlowListScores -> Map Parent GroupedWithListScores
-fromListScores = Map.fromListWith (<>) . (map fromScores') . Map.toList
-  where
-    fromScores' :: (Text, FlowListScores) -> (Text, GroupedWithListScores)
-    fromScores' (t, fs) = case (keyWithMaxValue $ view fls_parents fs) of
-      Nothing     -> (t, GroupedWithListScores Set.empty (keyWithMaxValue $ view fls_listType fs))
-          -- Parent case: taking its listType, for now children Set is empty
- 
-      Just parent -> (parent, GroupedWithListScores (Set.singleton t) Nothing)
-          -- We ignore the ListType of children for the parents' one
-          -- added after and winner of semigroup actions
 

src/Gargantext/Core/Text/List/Social.hs

@@ -11,60 +11,25 @@ Portability : POSIX
 module Gargantext.Core.Text.List.Social
   where
 
-import Data.Map (Map)
-import Data.Maybe (fromMaybe)
-import Data.Semigroup (Semigroup(..))
-import Data.Set (Set)
+import Data.Monoid (mconcat)
 import Data.Text (Text)
-import Gargantext.API.Ngrams.Tools -- (getListNgrams)
+import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Text.List.Social.Find
-import Gargantext.Core.Text.List.Social.ListType
+import Gargantext.Core.Text.List.Social.Prelude
 import Gargantext.Core.Text.List.Social.Scores
 import Gargantext.Core.Types.Individu
-import Gargantext.Core.Types.Main
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Tree
 import Gargantext.Database.Schema.Ngrams
 import Gargantext.Prelude
-import qualified Data.Map   as Map
-import qualified Data.Set   as Set
-
-------------------------------------------------------------------------
-flowSocialList :: ( RepoCmdM env err m
-                  , CmdM     env err m
-                  , HasNodeError err
-                  , HasTreeError err
-                  )
-                  => User -> NgramsType -> Set Text
-                  -> m (Map ListType (Set Text))
-flowSocialList user nt ngrams' = do
-  -- Here preference to privateLists (discutable: let user choice)
-  privateListIds <- findListsId user Private
-  privateLists <- flowSocialListByMode privateListIds nt ngrams'
-  -- printDebug "* privateLists *: \n" privateLists
-
-  sharedListIds <- findListsId user Shared
-  sharedLists  <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists)
-  -- printDebug "* sharedLists *: \n" sharedLists
-
-  -- TODO publicMapList:
-  -- Note: if both produce 3 identic repetition => refactor mode
-  -- publicListIds <- findListsId Public user
-  -- publicLists   <- flowSocialListByMode' publicListIds nt (termsByList CandidateTerm privateLists)
-
-  let result = parentUnionsExcl
-             [ Map.mapKeys (fromMaybe CandidateTerm) privateLists
-             , Map.mapKeys (fromMaybe CandidateTerm) sharedLists
-             -- , Map.mapKeys (fromMaybe CandidateTerm) publicLists
-             ]
-  -- printDebug "* socialLists *: results \n" result
-  pure result
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
+-- | Main parameters
+
 -- | FlowSocialListPriority
 -- Sociological assumption: either private or others (public) first
 -- This parameter depends on the user choice
@@ -74,58 +39,6 @@ flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
 flowSocialListPriority MySelfFirst = [Private, Shared{-, Public -}]
 flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
 
-------------------------------------------------------------------------
-flowSocialList' :: ( RepoCmdM env err m
-                   , CmdM     env err m
-                   , HasNodeError err
-                   , HasTreeError err
-                   )
-                  => FlowSocialListPriority
-                  -> User -> NgramsType -> Set Text
-                  -> m (Map Text FlowListScores)
-flowSocialList' flowPriority user nt ngrams' =
-  parentUnionsExcl <$> mapM (flowSocialListByMode' user nt ngrams')
-                            (flowSocialListPriority flowPriority)
-
-------------------------------------------------------------------------
-flowSocialListByMode :: ( RepoCmdM env err m
-                        , CmdM     env err m
-                        , HasNodeError err
-                        , HasTreeError err
-                        )
-                     => [NodeId]-> NgramsType -> Set Text
-                     -> m (Map (Maybe ListType) (Set Text))
-flowSocialListByMode      [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
-flowSocialListByMode listIds  nt ngrams' = do
-    counts  <- countFilterList ngrams' nt listIds Map.empty
-    let r = toSocialList counts ngrams'
-    pure r
-
-
-flowSocialListByMode' :: ( RepoCmdM env err m
-                         , CmdM     env err m
-                         , HasNodeError err
-                         , HasTreeError err
-                         )
-                      => User -> NgramsType -> Set Text -> NodeMode 
-                      -> m (Map Text FlowListScores)
-flowSocialListByMode' user nt st mode =
-      findListsId user mode
-  >>= flowSocialListByModeWith nt st
-
-
-flowSocialListByModeWith :: ( RepoCmdM env err m
-                            , CmdM     env err m
-                            , HasNodeError err
-                            , HasTreeError err
-                            )
-                         => NgramsType -> Set Text -> [NodeId]
-                         -> m (Map Text FlowListScores)
-flowSocialListByModeWith nt st ns =
-      mapM (\l -> getListNgrams [l] nt) ns
-  >>= pure
-    . toFlowListScores (keepAllParents nt) st Map.empty
-
 
 -- | We keep the parents for all ngrams but terms
 keepAllParents :: NgramsType -> KeepAllParents
@@ -133,67 +46,44 @@ keepAllParents NgramsTerms = KeepAllParents False
 keepAllParents _           = KeepAllParents True
 
 ------------------------------------------------------------------------
--- TODO: maybe use social groups too
--- | TODO what if equality ?
--- choice depends on Ord instance of ListType
--- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
--- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
--- (we minimize errors on MapTerms if doubt)
-toSocialList :: Map Text (Map ListType Int)
-             -> Set Text
-             -> Map (Maybe ListType) (Set Text)
-toSocialList m = Map.fromListWith (<>)
-               . Set.toList
-               . Set.map (toSocialList1 m)
-
-toSocialList1 :: Map Text (Map ListType Int)
-             -> Text
-             -> (Maybe ListType, Set Text)
-toSocialList1 m t = case Map.lookup t m of
-  Nothing -> (Nothing, Set.singleton t)
-  Just  m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
-              , Set.singleton t
-              )
-
-toSocialList1_testIsTrue :: Bool
-toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
-  where
-    result = toSocialList1 (Map.fromList [(token, m)]) token
-    token  = "token"
-    m = Map.fromList [ (CandidateTerm, 1)
-                     , (MapTerm      , 2)
-                     , (StopTerm     , 3)
-                     ]
-
-------------------------------------------------------------------------
--- | Tools
-------------------------------------------------------------------------
-termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
-termsByList CandidateTerm m = Set.unions
-                          $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
-                          [ Nothing, Just CandidateTerm ]
-termsByList l m =
-  fromMaybe Set.empty $ Map.lookup (Just l) m
-
-------------------------------------------------------------------------
-unions :: (Ord a, Semigroup a, Semigroup b, Ord b)
-      => [Map a (Set b)] -> Map a (Set b)
-unions = invertBack . Map.unionsWith (<>) . map invertForw
-
-invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
-invertForw = Map.unionsWith (<>)
-           . (map (\(k,sets) -> Map.fromSet (\_ -> k) sets))
-           . Map.toList
-
-invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
-invertBack = Map.fromListWith (<>)
-           . (map (\(b,a) -> (a, Set.singleton b)))
-           .  Map.toList
-
-unions_test :: Map ListType (Set Text)
-unions_test = unions [m1, m2]
-  where
-    m1 = Map.fromList [ (StopTerm     , Set.singleton "Candidate")]
-    m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
-                      , (MapTerm      , Set.singleton "Candidate")
-                      ]
+flowSocialList' :: ( RepoCmdM env err m
+                   , CmdM     env err m
+                   , HasNodeError err
+                   , HasTreeError err
+                   )
+                  => FlowSocialListPriority
+                  -> User -> NgramsType
+                  -> FlowCont Text FlowListScores
+                  -> m (FlowCont Text FlowListScores)
+flowSocialList' flowPriority user nt flc =
+  mconcat <$> mapM (flowSocialListByMode'   user nt flc)
+                   (flowSocialListPriority flowPriority)
+    where
+
+      flowSocialListByMode' :: ( RepoCmdM env err m
+                               , CmdM     env err m
+                               , HasNodeError err
+                               , HasTreeError err
+                               )
+                            => User -> NgramsType
+                            -> FlowCont Text FlowListScores
+                            -> NodeMode
+                            -> m (FlowCont Text FlowListScores)
+      flowSocialListByMode' user' nt' flc' mode =
+            findListsId user' mode
+        >>= flowSocialListByModeWith nt' flc'
+
+
+      flowSocialListByModeWith :: ( RepoCmdM env err m
+                                  , CmdM     env err m
+                                  , HasNodeError err
+                                  , HasTreeError err
+                                  )
+                               => NgramsType
+                               -> FlowCont Text FlowListScores
+                               -> [NodeId]
+                               -> m (FlowCont Text FlowListScores)
+      flowSocialListByModeWith nt'' flc'' ns =
+            mapM (\l -> getListNgrams [l] nt'') ns
+        >>= pure
+          . toFlowListScores (keepAllParents nt'') flc''

src/Gargantext/Core/Text/List/Social/Find.hs

@@ -12,6 +12,7 @@ module Gargantext.Core.Text.List.Social.Find
   where
 
 -- findList imports
+import Control.Lens (view)
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Admin.Config
 import Gargantext.Database.Admin.Types.Node
@@ -25,18 +26,21 @@ import Gargantext.Prelude
 findListsId :: (HasNodeError err, HasTreeError err)
             => User -> NodeMode -> Cmd err [NodeId]
 findListsId u mode = do
-  r <- getRootId u
-  ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
-                       <$> findNodes' mode r
+  rootId <- getRootId u
+  ns <- map (view dt_nodeId) <$> filter ((== nodeTypeId NodeList) . (view dt_typeId))
+                             <$> findNodes' rootId mode
   pure ns
 
-
+-- | TODO not clear enough:
+-- | Shared is for Shared with me but I am not the owner of it
+-- | Private is for all Lists I have created
 findNodes' :: HasTreeError err
-          => NodeMode -> RootId
+          => RootId
+          -> NodeMode
           -> Cmd err [DbTreeNode]
-findNodes' Private r = findNodes Private r $ [NodeFolderPrivate] <> commonNodes
-findNodes' Shared  r = findNodes Shared  r $ [NodeFolderShared ] <> commonNodes
-findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes
+findNodes' r Private = findNodes r Private $ [NodeFolderPrivate]          <> commonNodes
+findNodes' r Shared  = findNodes r Shared  $ [NodeFolderShared, NodeTeam] <> commonNodes
+findNodes' r Public  = findNodes r Public  $ [NodeFolderPublic ]          <> commonNodes
 
 commonNodes:: [NodeType]
-commonNodes = [NodeFolder, NodeCorpus, NodeList]
+commonNodes = [NodeFolder, NodeCorpus, NodeList, NodeFolderShared, NodeTeam]

src/Gargantext/Core/Text/List/Social/ListType.hs

-{-|
-Module      : Gargantext.Core.Text.List.Social.ListType
-Description :
-Copyright   : (c) CNRS, 2018-Present
-License     : AGPL + CECILL v3
-Maintainer  : team@gargantext.org
-Stability   : experimental
-Portability : POSIX
--}
-
-module Gargantext.Core.Text.List.Social.ListType
-  where
-
-import Gargantext.Database.Admin.Types.Node
-import Data.Map (Map)
-import Data.Set (Set)
-import Data.Text (Text)
-import Gargantext.Prelude
-import Gargantext.API.Ngrams.Tools -- (getListNgrams)
-import Gargantext.API.Ngrams.Types
-import Gargantext.Core.Types.Main
-import Gargantext.Database.Schema.Ngrams
-import qualified Data.List  as List
-import qualified Data.Map   as Map
-import qualified Data.Set   as Set
-
-------------------------------------------------------------------------
--- | [ListId] does not merge the lists (it is for Master and User lists
--- here we need UserList only
-countFilterList :: RepoCmdM env err m
-        => Set Text -> NgramsType -> [ListId]
-        ->    Map Text (Map ListType Int)
-        -> m (Map Text (Map ListType Int))
-countFilterList st nt ls input =
-  foldM' (\m l -> countFilterList' st nt [l] m) input ls
-    where
-      countFilterList' :: RepoCmdM env err m
-              => Set Text -> NgramsType -> [ListId]
-              ->    Map Text (Map ListType Int)
-              -> m (Map Text (Map ListType Int))
-      countFilterList' st' nt' ls' input' = do
-        ml <- toMapTextListType <$> getListNgrams ls' nt'
-        pure $ Set.foldl' (\m t -> countList t ml m) input' st'
-
-------------------------------------------------------------------------
--- FIXME children have to herit the ListType of the parent
-toMapTextListType :: Map Text NgramsRepoElement -> Map Text ListType
-toMapTextListType m = Map.fromListWith (<>)
-                    $ List.concat
-                    $ map (toList m)
-                    $ Map.toList m
-  where
-    toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
-    toList m' (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
-         List.zip terms (List.cycle [lt'])
-          where
-            terms =  [t]
-                  -- <> maybe [] (\n -> [unNgramsTerm n]) root
-                  -- <> maybe [] (\n -> [unNgramsTerm n]) parent
-                  <> (map unNgramsTerm $ Map.keys children)
-            lt'   = listOf m' nre
-
-            listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
-            listOf m'' ng = case _nre_parent ng of
-              Nothing -> _nre_list ng
-              Just  p -> case Map.lookup (unNgramsTerm p) m'' of
-                Just ng' -> listOf m'' ng'
-                Nothing  -> CandidateTerm
-                -- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
-
-------------------------------------------------------------------------
-countList :: Text
-          -> Map Text ListType
-          -> Map Text (Map ListType Int)
-          -> Map Text (Map ListType Int)
-countList t m input = case Map.lookup t m of
-  Nothing -> input
-  Just l  -> Map.alter addList t input
-    where
-
-      addList Nothing   = Just $ addCountList l Map.empty
-      addList (Just lm) = Just $ addCountList l lm
-
-      addCountList :: ListType -> Map ListType Int -> Map ListType Int
-      addCountList l' m' = Map.alter (plus l') l'  m'
-        where
-          plus CandidateTerm Nothing  = Just 1
-          plus CandidateTerm (Just x) = Just $ x + 1
-
-          plus MapTerm Nothing              = Just 2
-          plus MapTerm (Just x)             = Just $ x + 2
-
-          plus StopTerm Nothing              = Just 3
-          plus StopTerm (Just x)             = Just $ x + 3
-

src/Gargantext/Core/Text/List/Social/Prelude.hs

+{-|
+Module      : Gargantext.Core.Text.List.Social.Prelude
+Description :
+Copyright   : (c) CNRS, 2018-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+------------------------------------------------------------------------
+{-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE TypeFamilies      #-}
+------------------------------------------------------------------------
+module Gargantext.Core.Text.List.Social.Prelude
+  where
+
+import Control.Lens
+import Data.Semigroup (Semigroup(..))
+import Data.Monoid
+import Data.Map (Map)
+import Data.Text (Text)
+import Gargantext.Core.Types.Main
+import Gargantext.Prelude
+import GHC.Generics (Generic)
+import qualified Data.Map   as Map
+
+------------------------------------------------------------------------
+type Parent = Text
+------------------------------------------------------------------------
+-- | DataType inspired by continuation Monad (but simpler)
+data FlowCont a b =
+  FlowCont { _flc_scores :: Map a b
+           , _flc_cont   :: Map a b
+           }
+
+instance (Ord a, Eq b) => Monoid (FlowCont a b) where
+  mempty = FlowCont mempty mempty
+
+instance (Eq a, Ord a, Eq b) => Semigroup (FlowCont a b) where
+  (<>) (FlowCont  m1    s1)
+       (FlowCont  m2    s2)
+      = FlowCont (m1 <> m2)
+                 (s1 <> s2)
+
+makeLenses ''FlowCont
+
+-- | Datatype definition
+data FlowListScores =
+  FlowListScores { _fls_listType :: Map ListType Int
+                 , _fls_parents  :: Map Parent   Int
+                -- You can add any score by incrementing this type
+                -- , _flc_score   :: Map Score Int
+                 }
+    deriving (Show, Generic, Eq)
+
+makeLenses ''FlowListScores
+
+-- | Rules to compose 2 datatype FlowListScores
+-- About the shape of the Type fun:
+-- Triangle de Pascal, nombre d'or ou pi ?
+-- Question: how to add a score field and derive such definition
+-- without the need to fix it below ?
+instance Semigroup FlowListScores where
+  (<>) (FlowListScores p1 l1)
+       (FlowListScores p2 l2) =
+        FlowListScores (p1 <> p2)
+                       (l1 <> l2)
+
+instance Monoid FlowListScores where
+  mempty = FlowListScores Map.empty Map.empty
+
+------------------------------------------------------------------------
+-- | Tools to inherit groupings
+------------------------------------------------------------------------
+-- | Tools
+parentUnionsMerge :: (Ord a, Ord b, Num c)
+                   => [Map a (Map b c)]
+                   ->  Map a (Map b c)
+parentUnionsMerge = Map.unionsWith (Map.unionWith (+))
+
+-- This Parent union is specific
+-- [Private, Shared, Public]
+-- means the following preferences:
+-- Private > Shared > Public
+-- if data have not been tagged privately, then use others tags
+-- This unions behavior takes first key only and ignore others
+parentUnionsExcl :: Ord a
+                 => [Map a b]
+                 ->  Map a b
+parentUnionsExcl = Map.unions
+
+
+------------------------------------------------------------------------
+
+hasParent :: Text
+          -> Map Text (Map Parent Int)
+          -> Maybe Parent
+hasParent t m = case Map.lookup t m of
+  Nothing  -> Nothing
+  Just  m' -> keyWithMaxValue m'
+
+------------------------------------------------------------------------
+keyWithMaxValue :: Map a b -> Maybe a
+keyWithMaxValue m = (fst . fst) <$> Map.maxViewWithKey m
+

src/Gargantext/Core/Text/List/Social/Scores.hs

@@ -14,103 +14,78 @@ Portability : POSIX
 {-# LANGUAGE TypeOperators     #-}
 {-# LANGUAGE TypeFamilies      #-}
 
-
 module Gargantext.Core.Text.List.Social.Scores
   where
 
 import Control.Lens
 import Data.Map (Map)
-import Data.Semigroup (Semigroup(..))
+import Data.Monoid (mempty)
 import Data.Set (Set)
 import Data.Text (Text)
-import GHC.Generics (Generic)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types.Main
+import Gargantext.Core.Text.List.Social.Prelude
 import Gargantext.Prelude
 import qualified Data.Map   as Map
 import qualified Data.Set   as Set
 
 ------------------------------------------------------------------------
--- | Tools to inherit groupings
-------------------------------------------------------------------------
-
--- | Tools
-parentUnionsMerge :: (Ord a, Ord b, Num c)
-                   => [Map a (Map b c)]
-                   ->  Map a (Map b c)
-parentUnionsMerge = Map.unionsWith (Map.unionWith (+))
-
--- This Parent union is specific
--- [Private, Shared, Public]
--- means the following preferences:
--- Private > Shared > Public
--- if data have not been tagged privately, then use others tags
--- This unions behavior takes first key only and ignore others
-parentUnionsExcl :: Ord a
-                 => [Map a b]
-                 ->  Map a b
-parentUnionsExcl = Map.unions
-
-------------------------------------------------------------------------
-type Parent = Text
-
-hasParent :: Text
-          -> Map Text (Map Parent Int)
-          -> Maybe Parent
-hasParent t m = case Map.lookup t m of
-  Nothing  -> Nothing
-  Just  m' -> keyWithMaxValue m'
-
-------------------------------------------------------------------------
-keyWithMaxValue :: Map a b -> Maybe a
-keyWithMaxValue m = (fst . fst) <$> Map.maxViewWithKey m
-
-------------------------------------------------------------------------
-data FlowListScores =
-  FlowListScores { _fls_parents   :: Map Parent   Int
-                 , _fls_listType :: Map ListType Int
-                -- You can add any score by incrementing this type
-                -- , _flc_score   :: Map Score Int
-                 }
-    deriving (Show, Generic)
-
-makeLenses ''FlowListScores
-
-instance Semigroup FlowListScores where
-  (<>) (FlowListScores p1 l1) (FlowListScores p2 l2) =
-    FlowListScores (p1 <> p2) (l1 <> l2)
-
-
-------------------------------------------------------------------------
-------------------------------------------------------------------------
--- | toFlowListScores which generate Score from list of Map Text
---   NgramsRepoElement
+-- | Generates Score from list of Map Text NgramsRepoElement
 toFlowListScores :: KeepAllParents
-                 -> Set Text
-                 ->  Map Text FlowListScores
+                 ->  FlowCont Text FlowListScores
                  -> [Map Text NgramsRepoElement]
-                 ->  Map Text FlowListScores
-toFlowListScores k ts = foldl' (toFlowListScores' k ts)
+                 ->  FlowCont Text FlowListScores
+toFlowListScores k flc_origin = foldl' (toFlowListScores_Level1 k flc_origin) mempty
+
   where
-    toFlowListScores' :: KeepAllParents
-                     -> Set Text
-                     -> Map Text FlowListScores
-                     -> Map Text NgramsRepoElement
-                     -> Map Text FlowListScores
-    toFlowListScores' k' ts' to' ngramsRepo =
-      Set.foldl' (toFlowListScores'' k' ts' ngramsRepo) to' ts'
-
-    toFlowListScores'' :: KeepAllParents
-                       -> Set Text
-                       -> Map Text NgramsRepoElement
-                       -> Map Text FlowListScores
-                       -> Text
-                       -> Map Text FlowListScores
-    toFlowListScores'' k'' ss ngramsRepo to'' t =
+    toFlowListScores_Level1 :: KeepAllParents
+                            -> FlowCont Text FlowListScores
+                            -> FlowCont Text FlowListScores
+                            -> Map Text NgramsRepoElement
+                            -> FlowCont Text FlowListScores
+    toFlowListScores_Level1 k' flc_origin' flc_dest ngramsRepo =
+      Set.foldl' (toFlowListScores_Level2 k' ngramsRepo   flc_origin')
+                 flc_dest
+                 (Set.fromList $ Map.keys $ view flc_cont flc_origin')
+
+    toFlowListScores_Level2 :: KeepAllParents
+                            -> Map Text NgramsRepoElement
+                            -> FlowCont Text FlowListScores
+                            -> FlowCont Text FlowListScores
+                            -> Text
+                            -> FlowCont Text FlowListScores
+    toFlowListScores_Level2 k'' ngramsRepo flc_origin'' flc_dest' t =
       case Map.lookup t ngramsRepo of
-        Nothing  -> to''
-        Just nre -> Map.alter (addParent k'' nre ss)        t
-                  $ Map.alter (addList $ _nre_list nre) t to''
+        Nothing  -> over flc_cont   (Map.union $ Map.singleton t mempty) flc_dest'
+        Just nre -> updateScoresParent k'' ngramsRepo nre flc_origin''
+                  $ updateScores       k'' t nre setText flc_dest'
+          where
+            setText = Set.fromList
+                    $ Map.keys
+                    $ view flc_cont flc_origin''
+
+
+    updateScoresParent :: KeepAllParents -> Map Text NgramsRepoElement -> NgramsRepoElement
+                 -> FlowCont Text FlowListScores
+                 -> FlowCont Text FlowListScores
+                 -> FlowCont Text FlowListScores
+    updateScoresParent keep@(KeepAllParents k''') ngramsRepo nre flc_origin'' flc_dest'' = case k''' of
+                  False -> flc_dest''
+                  True  -> case view nre_parent nre of
+                    Nothing                  -> flc_dest''
+                    Just (NgramsTerm parent) -> toFlowListScores_Level2 keep ngramsRepo flc_origin'' flc_dest'' parent
+
+
+------------------------------------------------------------------------
+updateScores :: KeepAllParents
+             -> Text -> NgramsRepoElement -> Set Text
+             -> FlowCont Text FlowListScores
+             -> FlowCont Text FlowListScores
+updateScores k t nre setText mtf =
+    over flc_cont   ( Map.delete t)
+  $ over flc_scores ((Map.alter (addParent k nre setText  ) t)
+                    .(Map.alter (addList $ view nre_list nre) t)
+                    ) mtf
 
 ------------------------------------------------------------------------
 -- | Main addFunctions to groupResolution the FlowListScores
@@ -120,18 +95,17 @@ addList :: ListType
         -> Maybe FlowListScores
         -> Maybe FlowListScores
 addList l Nothing =
-  Just $ FlowListScores Map.empty (addList' l Map.empty)
+  Just $ set fls_listType (addListScore l mempty) mempty
+
+addList l (Just fls) =
+  Just $ over fls_listType (addListScore l) fls
 
-addList l (Just (FlowListScores mapParent mapList)) =
-  Just $ FlowListScores mapParent mapList'
-    where
-      mapList' = addList' l mapList
 -- * Unseful but nice comment:
 -- "the addList function looks like an ASCII bird"
 
 -- | Concrete function to pass to PatchMap
-addList' :: ListType -> Map ListType Int -> Map ListType Int
-addList' l m = Map.alter (plus l) l  m
+addListScore :: ListType -> Map ListType Int -> Map ListType Int
+addListScore l m = Map.alter (plus l) l  m
   where
     plus CandidateTerm Nothing  = Just 1
     plus CandidateTerm (Just x) = Just $ x + 1
@@ -142,7 +116,6 @@ addList' l m = Map.alter (plus l) l  m
     plus StopTerm Nothing       = Just 3
     plus StopTerm (Just x)      = Just $ x + 3
 
-------------------------------------------------------------------------
 ------------------------------------------------------------------------
 data KeepAllParents = KeepAllParents Bool
 
@@ -151,24 +124,22 @@ addParent :: KeepAllParents -> NgramsRepoElement -> Set Text
           -> Maybe FlowListScores
 
 addParent k nre ss Nothing  =
-  Just $ FlowListScores mapParent Map.empty
+  Just $ FlowListScores mempty mapParent
     where
-      mapParent = addParent' k (_nre_parent nre) ss Map.empty
+      mapParent = addParentScore k (view nre_parent nre) ss mempty
 
-addParent k nre ss (Just (FlowListScores mapParent mapList)) =
-  Just $ FlowListScores mapParent' mapList
-    where
-      mapParent' = addParent' k (_nre_parent nre) ss mapParent
+addParent k nre ss (Just fls{-(FlowListScores mapList mapParent)-}) =
+  Just $ over fls_parents (addParentScore k (view nre_parent nre) ss) fls
 
-addParent' :: Num a
+addParentScore :: Num a
            => KeepAllParents
            -> Maybe NgramsTerm
            -> Set Text
            -> Map Text a
            -> Map Text a
-addParent' _ Nothing               _ss mapParent = mapParent
-addParent' (KeepAllParents k) (Just (NgramsTerm p')) ss mapParent =
-  case k of
+addParentScore _ Nothing                                   _ss mapParent = mapParent
+addParentScore (KeepAllParents keep) (Just (NgramsTerm p')) ss mapParent =
+  case keep of
     True  -> Map.alter addCount p' mapParent
     False -> case Set.member p' ss of
                False -> mapParent
@@ -178,3 +149,4 @@ addParent' (KeepAllParents k) (Just (NgramsTerm p')) ss mapParent =
         addCount (Just n) = Just $ n + 1
 
 ------------------------------------------------------------------------
+------------------------------------------------------------------------

src/Gargantext/Core/Text/Metrics.hs

@@ -11,14 +11,17 @@ Mainly reexport functions in @Data.Text.Metrics@
 
 -}
 
-{-# LANGUAGE BangPatterns      #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 module Gargantext.Core.Text.Metrics
   where
 
 --import Data.Array.Accelerate ((:.)(..), Z(..))
 --import Math.KMeans (kmeans, euclidSq, elements)
+import Control.Lens (makeLenses)
 import Data.Map (Map)
+import Data.Semigroup (Semigroup)
+import Data.Monoid (Monoid, mempty)
 import Gargantext.Prelude
 import Gargantext.Core.Methods.Distances.Accelerate.SpeGen
 import Gargantext.Core.Viz.Graph.Index
@@ -46,8 +49,17 @@ data Scored ts = Scored
   { _scored_terms  :: !ts
   , _scored_genInc :: !GenericityInclusion
   , _scored_speExc :: !SpecificityExclusion
-  } deriving (Show)
+  } deriving (Show, Eq, Ord)
 
+instance Monoid a => Monoid (Scored a) where
+  mempty = Scored mempty mempty mempty
+
+instance Semigroup a => Semigroup (Scored a) where
+  (<>) (Scored a  b  c )
+       (Scored _a' b' c')
+      = Scored (a {-<> a'-})
+               (b <> b')
+               (c <> c')
 
 localMetrics' :: Ord t => Map (t,t) Int -> Map t (Vec.Vector Double)
 localMetrics' m = Map.fromList $ zipWith (\(_,t) (inc,spe) -> (t, Vec.fromList [inc,spe]))
@@ -96,5 +108,5 @@ normalizeLocal (Scored t s1 s2) = Scored t (log' 5 s1) (log' 2 s2)
 
 
 
-
-
+-- | Type Instances
+makeLenses 'Scored

src/Gargantext/Core/Types/Individu.hs

@@ -52,7 +52,7 @@ data NewUser a = NewUser { _nu_username :: Username
   deriving (Show)
 
 arbitraryUsername :: [Username]
-arbitraryUsername = ["gargantua"] <> users
+arbitraryUsername = {- ["gargantua"] <> -} users
   where
     users = zipWith (\a b -> a <> (pack . show) b) 
                     (repeat "user") ([1..20]::[Int])
@@ -68,12 +68,13 @@ toUserHash (NewUser u m (GargPassword p)) = do
   h <- Auth.createPasswordHash p
   pure $ NewUser u m h
 
+-- TODO remove
 arbitraryUsersHash :: MonadIO m
                   => m [NewUser HashPassword]
-arbitraryUsersHash = mapM toUserHash arbitraryUsers
+arbitraryUsersHash = mapM toUserHash arbitraryNewUsers
 
-arbitraryUsers :: [NewUser GargPassword]
-arbitraryUsers = map (\u -> NewUser u (u <> "@gargantext.org") (GargPassword $ reverse u))
+arbitraryNewUsers :: [NewUser GargPassword]
+arbitraryNewUsers = map (\u -> NewUser u (u <> "@gargantext.org") (GargPassword $ reverse u))
                      arbitraryUsername
 
 

src/Gargantext/Core/Viz/Chart.hs

@@ -31,7 +31,7 @@ import Gargantext.Prelude
 import Gargantext.Core.Text.Metrics.Count (occurrencesWith)
 
 -- Pie Chart
-import Gargantext.API.Ngrams.NTree
+import Gargantext.API.Ngrams.NgramsTree
 import Gargantext.API.Ngrams.Tools
 import Gargantext.Core.Types
 import Gargantext.Database.Action.Flow
@@ -71,7 +71,7 @@ chartData cId nt lt = do
 
 treeData :: FlowCmdM env err m
         => CorpusId -> NgramsType -> ListType
-        -> m [MyTree]
+        -> m [NgramsTree]
 treeData cId nt lt = do
   ls' <- selectNodesWithUsername NodeList userMaster
   ls <- map (_node_id) <$> getListsWithParentId cId

src/Gargantext/Database/Action/Share.hs

@@ -32,13 +32,12 @@ publicNodeTypes :: [NodeType]
 publicNodeTypes = [NodeDashboard, NodeGraph, NodePhylo, NodeFile]
 
 ------------------------------------------------------------------------
-
 data ShareNodeWith = ShareNodeWith_User { snwu_nodetype :: NodeType
-                                        , snwu_user    :: User }
+                                        , snwu_user     :: User
+                                        }
                    | ShareNodeWith_Node { snwn_nodetype :: NodeType
-                                        , snwn_node_id :: NodeId
+                                        , snwn_node_id  :: NodeId
                                         }
-
 ------------------------------------------------------------------------
 shareNodeWith :: HasNodeError err
               => ShareNodeWith
@@ -86,7 +85,6 @@ delFolderTeam u nId = do
   folderSharedId <- getFolderId u NodeFolderShared
   deleteNodeNode folderSharedId nId
 
-
 unPublish :: HasNodeError err
           => ParentId -> NodeId
           -> Cmd err Int

src/Gargantext/Database/Action/User.hs

@@ -27,16 +27,25 @@ import Gargantext.Prelude
 getUserId :: HasNodeError err
           => User
           -> Cmd err UserId
-getUserId (UserDBId uid) = pure uid
-getUserId (RootId   rid) = do
+getUserId u = do
+  maybeUser <- getUserId' u
+  case maybeUser of
+    Nothing -> nodeError NoUserFound
+    Just u'  -> pure u'
+
+getUserId' :: HasNodeError err
+          => User
+          -> Cmd err (Maybe UserId)
+getUserId' (UserDBId uid) = pure (Just uid)
+getUserId' (RootId   rid) = do
   n <- getNode rid
-  pure $ _node_userId n
-getUserId (UserName u  ) = do
+  pure $ Just $ _node_userId n
+getUserId' (UserName u  ) = do
   muser <- getUser u
   case muser of
-    Just user -> pure $ userLight_id user
-    Nothing   -> nodeError NoUserFound
-getUserId UserPublic = nodeError NoUserFound
+    Just user -> pure $ Just $ userLight_id user
+    Nothing   -> pure Nothing
+getUserId' UserPublic = pure Nothing
 
 ------------------------------------------------------------------------
 -- | Username = Text

src/Gargantext/Database/Action/User/New.hs

@@ -26,7 +26,7 @@ import Gargantext.Prelude
 import Gargantext.Prelude.Config
 import Gargantext.Prelude.Crypto.Pass.User (gargPass)
 import Gargantext.Prelude.Mail (gargMail, GargMail(..))
-
+import qualified Data.List as List
 
 ------------------------------------------------------------------------
 type EmailAddress = Text
@@ -42,14 +42,20 @@ newUserQuick :: (MonadRandom m)
              => Text -> m (NewUser GargPassword)
 newUserQuick n = do
   pass <- gargPass
-  let (u,_m) = guessUserName n
+  let u = case guessUserName n of
+        Just  (u', _m) -> u'
+        Nothing        -> panic "[G.D.A.U.N.newUserQuick]: Email invalid"
   pure (NewUser u n (GargPassword pass))
 
-guessUserName :: Text -> (Text,Text)
+------------------------------------------------------------------------
+isEmail :: Text -> Bool
+isEmail = ((==) 2) . List.length . (splitOn "@")
+
+guessUserName :: Text -> Maybe (Text,Text)
 guessUserName n = case splitOn "@" n of
-    [u',m'] -> if m' /= "" then (u',m')
-                           else panic "Email Invalid"
-    _  -> panic "Email invalid"
+    [u',m'] -> if m' /= "" then Just (u',m')
+                           else Nothing
+    _       -> Nothing
 ------------------------------------------------------------------------
 newUser' :: HasNodeError err
         => Text -> NewUser GargPassword -> Cmd err Int64
@@ -58,18 +64,23 @@ newUser' address u = newUsers' address [u]
 newUsers' :: HasNodeError err
          => Text -> [NewUser GargPassword] -> Cmd err Int64
 newUsers' address us = do
-  us' <- liftBase    $ mapM toUserHash us
-  r   <- insertUsers $ map toUserWrite us'
+  us' <- liftBase         $ mapM toUserHash us
+  r   <- insertUsers      $ map toUserWrite us'
   _   <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us
-  _   <- liftBase    $ mapM (mail Invitation address) us
+  _   <- liftBase         $ mapM (mail Invitation address) us
   pure r
 ------------------------------------------------------------------------
+
+data SendEmail = SendEmail Bool
+
 updateUser :: HasNodeError err
-           => Text -> NewUser GargPassword -> Cmd err Int64
-updateUser address u = do
-  u' <- liftBase   $ toUserHash   u
+           => SendEmail -> Text -> NewUser GargPassword -> Cmd err Int64
+updateUser (SendEmail send) address u = do
+  u' <- liftBase     $ toUserHash   u
   n  <- updateUserDB $ toUserWrite  u'
-  _  <- liftBase   $ mail Update address u
+  _  <- case send of
+     True  -> liftBase     $ mail Update address u
+     False -> pure ()
   pure n
 
 ------------------------------------------------------------------------

src/Gargantext/Database/Admin/Types/Hyperdata/List.hs

@@ -27,7 +27,7 @@ import Control.Applicative
 
 import Gargantext.Prelude
 import Gargantext.Core.Viz.Types (Histo(..))
-import Gargantext.API.Ngrams.NTree (MyTree)
+import Gargantext.API.Ngrams.NgramsTree (NgramsTree)
 import Gargantext.API.Ngrams.Types (TabType)
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
 import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metrics)
@@ -38,13 +38,13 @@ data HyperdataList =
                 , _hl_list    :: !(Maybe Text)
                 , _hl_pie     :: !(Map TabType (ChartMetrics Histo))
                 , _hl_scatter :: !(Map TabType Metrics)
-                , _hl_tree    :: !(Map TabType (ChartMetrics [MyTree]))
+                , _hl_tree    :: !(Map TabType (ChartMetrics [NgramsTree]))
                 } deriving (Show, Generic)
   -- HyperdataList { _hl_chart   :: !(Maybe (ChartMetrics Histo))
   --               , _hl_list    :: !(Maybe Text)
   --               , _hl_pie     :: !(Maybe (ChartMetrics Histo))
   --               , _hl_scatter :: !(Maybe Metrics)
-  --               , _hl_tree    :: !(Maybe (ChartMetrics [MyTree]))
+  --               , _hl_tree    :: !(Maybe (ChartMetrics [NgramsTree]))
   --               } deriving (Show, Generic)
 
 defaultHyperdataList :: HyperdataList

src/Gargantext/Database/Prelude.hs

@@ -80,10 +80,17 @@ type CmdM env err m =
   , HasConfig         env
   )
 
+type CmdRandom env err m =
+  ( CmdM'             env err m
+  , HasConnectionPool env
+  , HasConfig         env
+  , MonadRandom             m
+  )
+
 type Cmd'' env err a = forall m.     CmdM'' env err m => m a
 type Cmd'  env err a = forall m.     CmdM'  env err m => m a
 type Cmd       err a = forall m env. CmdM   env err m => m a
-
+type CmdR      err a = forall m env. CmdRandom   env err m => m a
 
 
 

src/Gargantext/Database/Query/Table/User.hs

@@ -24,7 +24,7 @@ module Gargantext.Database.Query.Table.User
   , updateUserDB
   , queryUserTable
   , getUser
-  , insertUsersDemo
+  , insertNewUsers
   , selectUsersLightWith
   , userWithUsername
   , userWithId
@@ -81,7 +81,7 @@ toUserWrite (NewUser u m (Auth.PasswordHash p)) =
          (pgStrictText "first_name")
          (pgStrictText "last_name")
          (pgStrictText m)
-         (pgBool True) 
+         (pgBool True)
          (pgBool True) Nothing
 
 ------------------------------------------------------------------
@@ -141,9 +141,9 @@ getUser u = userLightWithUsername u <$> usersLight
 
 
 ----------------------------------------------------------------------
-insertUsersDemo :: Cmd err Int64
-insertUsersDemo = do
-  users <- liftBase arbitraryUsersHash
+insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
+insertNewUsers newUsers = do
+  users <- liftBase $ mapM toUserHash newUsers
   insertUsers $ map toUserWrite users
 
 ----------------------------------------------------------------------

src/Gargantext/Database/Query/Tree.hs

@@ -34,7 +34,7 @@ module Gargantext.Database.Query.Tree
   )
   where
 
-import Control.Lens ((^..), at, each, _Just, to, set, makeLenses)
+import Control.Lens (view, toListOf, at, each, _Just, to, set, makeLenses)
 import Control.Monad.Error.Class (MonadError())
 import Data.List (tail, concat, nub)
 import Data.Map (Map, fromListWith, lookup)
@@ -93,22 +93,22 @@ tree_advanced :: HasTreeError err
               -> [NodeType]
               -> Cmd err (Tree NodeTree)
 tree_advanced r nodeTypes = do
-  mainRoot    <- findNodes Private r nodeTypes
-  sharedRoots <- findNodes Shared  r nodeTypes
-  publicRoots <- findNodes Public  r nodeTypes
+  mainRoot    <- findNodes r Private nodeTypes
+  sharedRoots <- findNodes r Shared  nodeTypes
+  publicRoots <- findNodes r Public  nodeTypes
   toTree      $ toTreeParent (mainRoot <> sharedRoots <> publicRoots)
 
 ------------------------------------------------------------------------
 data NodeMode = Private | Shared | Public
 
 findNodes :: HasTreeError err
-          => NodeMode
-          -> RootId -> [NodeType]
+          => RootId
+          -> NodeMode
+          -> [NodeType]
           -> Cmd err [DbTreeNode]
-findNodes Private r nt = dbTree r nt
-findNodes Shared  r nt = findShared r NodeFolderShared nt sharedTreeUpdate
-findNodes Public  r nt = findShared r NodeFolderPublic nt publicTreeUpdate
-
+findNodes r Private nt = dbTree r nt
+findNodes r Shared  nt = findShared r NodeFolderShared nt sharedTreeUpdate
+findNodes r Public  nt = findShared r NodeFolderPublic nt publicTreeUpdate
 
 ------------------------------------------------------------------------
 -- | Collaborative Nodes in the Tree
@@ -120,6 +120,7 @@ findShared r nt nts fun = do
   trees           <- mapM (updateTree nts fun) foldersSharedId
   pure $ concat trees
 
+
 type UpdateTree err = ParentId -> [NodeType] -> NodeId -> Cmd err [DbTreeNode]
 
 updateTree :: HasTreeError err
@@ -134,7 +135,7 @@ updateTree nts fun r = do
 
 sharedTreeUpdate :: HasTreeError err => UpdateTree err
 sharedTreeUpdate p nt n = dbTree n nt
-               <&> map (\n' -> if _dt_nodeId n' == n
+               <&> map (\n' -> if (view dt_nodeId n') == n
                                   -- && elem (fromNodeTypeId $ _dt_typeId n') [NodeGraph]
                                   -- && not (elem (fromNodeTypeId $ _dt_typeId n') [NodeFile])
                                   then set dt_parentId (Just p) n'
@@ -174,13 +175,14 @@ toTree m =
               -> Tree NodeTree
       toTree' m' n =
         TreeN (toNodeTree n) $
-          m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
+          -- | Lines below are equivalent computationally but not semantically
+          -- m' ^.. at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')
+          toListOf (at (Just $ _dt_nodeId n) . _Just . each . to (toTree' m')) m'
 
       toNodeTree :: DbTreeNode
                  -> NodeTree
-      toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
-        where
-          nodeType = fromNodeTypeId tId
+      toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromNodeTypeId tId) nId
+
 ------------------------------------------------------------------------
 toTreeParent :: [DbTreeNode]
              -> Map (Maybe ParentId) [DbTreeNode]

src/Gargantext/Prelude.hs

@@ -10,6 +10,7 @@ Portability : POSIX
 -}
 
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-orphans        #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults  #-}
 
 module Gargantext.Prelude
@@ -35,6 +36,8 @@ import GHC.Err.Located (undefined)
 import GHC.Real (round)
 import Data.Map (Map, lookup)
 import Data.Maybe (isJust, fromJust, maybe)
+import Data.Monoid (Monoid, mempty)
+import Data.Semigroup (Semigroup, (<>))
 import Data.Text (Text)
 import Data.Typeable (Typeable)
 import Protolude ( Bool(True, False), Int, Int64, Double, Integer
@@ -306,12 +309,31 @@ lookup2 a b m = do
   m' <- lookup a m
   lookup b m'
 
------------------------------------------------
-
+-----------------------------------------------------------------------
 foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
 foldM' _ z [] = return z
 foldM' f z (x:xs) = do
   z' <- f z x
   z' `seq` foldM' f z' xs
 
-
+-----------------------------------------------------------------------
+-- | Instance for basic numerals
+-- See the difference between Double and (Int Or Integer)
+instance Monoid Double where
+  mempty = 1
+
+instance Semigroup Double where
+  (<>) a b = a * b
+
+-----------
+instance Monoid Int where
+  mempty = 0
+
+instance Semigroup Int where
+  (<>) a b = a + b
+----
+instance Monoid Integer where
+  mempty = 0
+
+instance Semigroup Integer where
+  (<>) a b = a + b