Skip to content

haskell-gargantext
haskell-gargantext
Commit c02e87d8 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

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

parents 2a9bc706 77e4ab25
Pipeline #1267 failed with stage
    Expand all Hide whitespace changes
    Inline Side-by-side
    Showing with 1027 additions and 898 deletions
    bin/gargantext-import/Main.hs
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    {-# 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
    View file @ c02e87d8
    {-|
    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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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.hs
    View file @ c02e87d8
    This diff is collapsed.
    src/Gargantext/Core/Text/List/Group.hs
    View file @ c02e87d8
    ......@@ -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 0 → 100644
    View file @ c02e87d8
    {-|
    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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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 deleted 100644 → 0
    View file @ 2a9bc706
    {-|
    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 0 → 100644
    View file @ c02e87d8
    {-|
    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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    View file @ c02e87d8
    ......@@ -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
    Markdown is supported
    0% or
    You are about to add 0 people to the discussion. Proceed with caution.
    Finish editing this message first!
    Please register or to comment