[FLOW] mapNodeIdNgrams directly create the inner maps
[gargantext.git] / src / Gargantext / API / Ngrams.hs
index 830f1e7db55bcd6b01b7b2b085af1b0538365bcd..3f55ae65ef76e63ff097d21a344d9adc4928d3ee 100644 (file)
@@ -10,10 +10,6 @@ Portability : POSIX
 Ngrams API
 
 -- | TODO
--- get data of NgramsTable
--- post :: update NodeNodeNgrams
--- group ngrams
-
 get ngrams filtered by NgramsType
 add get 
 
@@ -23,56 +19,74 @@ add get
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeOperators     #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# OPTIONS -fno-warn-orphans #-}
 
 module Gargantext.API.Ngrams
   where
 
--- import Gargantext.Database.User  (UserId)
---import Data.Map.Strict.Patch (Patch, replace, fromList)
+import Prelude (round)
+-- import Gargantext.Database.Schema.User  (UserId)
+import Data.Functor (($>))
+import Data.Patch.Class (Replace, replace, new)
+--import qualified Data.Map.Strict.Patch as PM
+import Data.Monoid
+--import Data.Semigroup
+import Data.Set (Set)
+import qualified Data.Set as Set
 --import Data.Maybe (catMaybes)
---import qualified Data.Map.Strict as DM
+-- import qualified Data.Map.Strict as DM
+import Data.Map.Strict (Map)
 --import qualified Data.Set as Set
-import Control.Lens (view)
-import Data.Aeson (FromJSON, ToJSON)
+import Control.Lens (makeLenses, Prism', prism', (^..), (.~), (#), to, withIndex, folded, ifolded)
+import Control.Monad (guard)
+import Control.Monad.Error.Class (MonadError, throwError)
+import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import Data.Either(Either(Left))
-import Data.List (concat)
-import Data.Set (Set)
-import Data.Swagger (ToSchema, ToParamSchema)
+import Data.Map (lookup)
+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
+import Data.Swagger hiding (version, patch)
 import Data.Text (Text)
-import Database.PostgreSQL.Simple (Connection)
 import GHC.Generics (Generic)
-import Gargantext.Core.Types (node_id)
-import Gargantext.Core.Types.Main (Tree(..))
 import Gargantext.Core.Utils.Prefix (unPrefix)
-import Gargantext.Database.Ngrams (NgramsId)
-import Gargantext.Database.Node (getListsWithParentId)
--- import Gargantext.Database.NodeNgram -- (NodeNgram(..), NodeNgram, updateNodeNgrams, NodeNgramPoly)
-import Gargantext.Database.NodeNgramsNgrams -- (NodeNgramsNgramsPoly(NodeNgramsNgrams))
+import Gargantext.Database.Types.Node (NodeType(..))
+import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
+import Gargantext.Database.Schema.Ngrams (NgramsType, NgramsTypeId, ngramsTypeId)
+import qualified Gargantext.Database.Schema.Ngrams as Ngrams
+import Gargantext.Database.Schema.NodeNgram
+import Gargantext.Database.Schema.NodeNgramsNgrams
+import Gargantext.Database.Utils (Cmd)
 import Gargantext.Prelude
-import Gargantext.Text.List.Types (ListType(..), ListId, ListTypeId) --,listTypeId )
+import Gargantext.Core.Types (ListType(..), ListTypeId, ListId, CorpusId, Limit, Offset, listTypeId)
 import Prelude (Enum, Bounded, minBound, maxBound)
 import Servant hiding (Patch)
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
--- import qualified Data.Set as Set
 
 ------------------------------------------------------------------------
 --data FacetFormat = Table | Chart
-data TabType   = Docs   | Terms  | Sources | Authors | Trash
+data TabType   = Docs     | Terms  | Sources | Authors | Institutes | Trash
+               | Contacts
   deriving (Generic, Enum, Bounded)
 
 instance FromHttpApiData TabType
   where
-    parseUrlPiece "Docs"    = pure Docs
-    parseUrlPiece "Terms"   = pure Terms
-    parseUrlPiece "Sources" = pure Sources
-    parseUrlPiece "Authors" = pure Authors
-    parseUrlPiece "Trash"   = pure Trash
-    parseUrlPiece _         = Left "Unexpected value of TabType"
+    parseUrlPiece "Docs"       = pure Docs
+    parseUrlPiece "Terms"      = pure Terms
+    parseUrlPiece "Sources"    = pure Sources
+    parseUrlPiece "Institutes" = pure Institutes
+    parseUrlPiece "Authors"    = pure Authors
+    parseUrlPiece "Trash"      = pure Trash
+    
+    parseUrlPiece "Contacts"   = pure Contacts
+    
+    parseUrlPiece _            = Left "Unexpected value of TabType"
 
 instance ToParamSchema   TabType
 instance ToJSON    TabType
@@ -83,41 +97,45 @@ instance Arbitrary TabType
     arbitrary = elements [minBound .. maxBound]
 
 ------------------------------------------------------------------------
+type NgramsTerm = Text
+
 data NgramsElement =
-     NgramsElement { _ne_ngrams      :: Text
+     NgramsElement { _ne_ngrams      :: NgramsTerm
                    , _ne_list        :: ListType
                    , _ne_occurrences :: Int
+                   , _ne_parent      :: Maybe NgramsTerm
+                   , _ne_children    :: Set NgramsTerm
                    }
       deriving (Ord, Eq, Show, Generic)
-$(deriveJSON (unPrefix "_ne_") ''NgramsElement)
+
+deriveJSON (unPrefix "_ne_") ''NgramsElement
+makeLenses ''NgramsElement
 
 instance ToSchema NgramsElement
 instance Arbitrary NgramsElement where
-  arbitrary = elements [NgramsElement "sport" StopList 1]
+  arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
 
 ------------------------------------------------------------------------
-data NgramsTable = NgramsTable { _ngramsTable :: [Tree NgramsElement] }
-  deriving (Ord, Eq, Generic)
-$(deriveJSON (unPrefix "_") ''NgramsTable)
+newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
+  deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 
 instance Arbitrary NgramsTable where
-  arbitrary = NgramsTable <$> arbitrary
-
--- TODO
-instance Arbitrary (Tree NgramsElement) where 
-  arbitrary = elements [ TreeN (NgramsElement "animal" GraphList 1) 
-                            [TreeN (NgramsElement "dog" GraphList 3) []
-                             , TreeN (NgramsElement "object" CandidateList 2) []
-                             , TreeN (NgramsElement "cat"     GraphList 1) []
-                             , TreeN (NgramsElement "nothing" StopList 4) []
-                            ]
-                       , TreeN (NgramsElement "plant" GraphList 3)
-                            [TreeN (NgramsElement "flower" GraphList 3) []
-                             , TreeN (NgramsElement "moon" CandidateList 1) []
-                             , TreeN (NgramsElement "cat"     GraphList 2) []
-                             , TreeN (NgramsElement "sky" StopList 1) []
-                            ]
-                       ]
+  arbitrary = elements
+              [ NgramsTable
+                [ NgramsElement "animal"  GraphList     1  Nothing       (Set.fromList ["dog", "cat"])
+                , NgramsElement "cat"     GraphList     1 (Just "animal") mempty
+                , NgramsElement "cats"    StopList      4  Nothing        mempty
+                , NgramsElement "dog"     GraphList     3 (Just "animal")(Set.fromList ["dogs"])
+                , NgramsElement "dogs"    StopList      4 (Just "dog")    mempty
+                , NgramsElement "fox"     GraphList     1  Nothing        mempty
+                , NgramsElement "object"  CandidateList 2  Nothing        mempty
+                , NgramsElement "nothing" StopList      4  Nothing        mempty
+                , NgramsElement "organic" GraphList     3  Nothing        (Set.singleton "flower")
+                , NgramsElement "flower"  GraphList     3 (Just "organic") mempty
+                , NgramsElement "moon"    CandidateList 1  Nothing         mempty
+                , NgramsElement "sky"     StopList      1  Nothing         mempty
+                ]
+              ]
 instance ToSchema NgramsTable
 
 ------------------------------------------------------------------------
@@ -126,43 +144,61 @@ instance ToSchema NgramsTable
 --            | OutGroup    NgramsId NgramsId
 --            | SetListType NgramsId ListType
 
-data NgramsPatch =
-     NgramsPatch { _np_list_types   :: ListType   -- TODO Map UserId ListType
-                 , _np_add_children :: Set NgramsElement
-                 , _np_rem_children :: Set NgramsElement
-                 }
-      deriving (Ord, Eq, Show, Generic)
-$(deriveJSON (unPrefix "_np_") ''NgramsPatch)
+data PatchSet a = PatchSet
+  { _rem :: Set a
+  , _add :: Set a
+  }
+  deriving (Eq, Ord, Show, Generic)
 
-instance ToSchema  NgramsPatch
+instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
+  arbitrary = PatchSet <$> arbitrary <*> arbitrary
 
-instance Arbitrary NgramsPatch where
-  arbitrary = NgramsPatch <$> arbitrary <*> arbitrary <*> arbitrary
+instance ToJSON a => ToJSON (PatchSet a) where
+  toJSON     = genericToJSON     $ unPrefix "_"
+  toEncoding = genericToEncoding $ unPrefix "_"
 
-                       --
+instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
+  parseJSON = genericParseJSON $ unPrefix "_"
 
-data NgramsIdPatch =
-     NgramsIdPatch { _nip_ngramsId    :: NgramsElement
-                   , _nip_ngramsPatch :: NgramsPatch
-                   }
+instance ToSchema a => ToSchema (PatchSet a)
+
+instance ToSchema a => ToSchema (Replace a) where
+  declareNamedSchema (_ :: proxy (Replace a)) = do
+    -- TODO Keep constructor is not supported here.
+    aSchema <- declareSchemaRef (Proxy :: Proxy a)
+    return $ NamedSchema (Just "Replace") $ mempty
+      & type_ .~ SwaggerObject
+      & properties .~
+          InsOrdHashMap.fromList
+          [ ("old", aSchema)
+          , ("new", aSchema)
+          ]
+      & required .~ [ "old", "new" ]
+
+data NgramsPatch =
+     NgramsPatch { _patch_children :: PatchSet NgramsTerm
+                 , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
+                 }
       deriving (Ord, Eq, Show, Generic)
+deriveJSON (unPrefix "_") ''NgramsPatch
+makeLenses ''NgramsPatch
 
-$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
+-- instance Semigroup NgramsPatch where
 
-instance ToSchema  NgramsIdPatch
+instance ToSchema  NgramsPatch
 
-instance Arbitrary NgramsIdPatch where
-  arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
+instance Arbitrary NgramsPatch where
+  arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 
-                       --
+newtype NgramsTablePatch =
+     NgramsTablePatch { _ntp_ngrams_patches :: Map NgramsTerm NgramsPatch }
+      deriving (Ord, Eq, Show, Generic, Arbitrary, ToJSON, FromJSON)
+makeLenses ''NgramsTablePatch
+instance ToSchema  NgramsTablePatch
 
-data NgramsIdPatchs =
-     NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
-      deriving (Ord, Eq, Show, Generic)
-$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
-instance ToSchema  NgramsIdPatchs
-instance Arbitrary NgramsIdPatchs where
-  arbitrary = NgramsIdPatchs <$> arbitrary
+-- TODO: replace by mempty once we have the Monoid instance
+emptyNgramsTablePatch :: NgramsTablePatch
+emptyNgramsTablePatch = NgramsTablePatch mempty
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
@@ -172,7 +208,12 @@ data Versioned a = Versioned
   { _v_version :: Version
   , _v_data    :: a
   }
-
+  deriving (Generic)
+deriveJSON (unPrefix "_v_") ''Versioned
+makeLenses ''Versioned
+instance ToSchema a => ToSchema (Versioned a)
+instance Arbitrary a => Arbitrary (Versioned a) where
+  arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 
 {-
 -- TODO sequencs of modifications (Patchs)
@@ -195,58 +236,118 @@ ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ n
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
-type CorpusId = Int
-type TableNgramsApi = Summary " Table Ngrams API Change"
-                      :> QueryParam "list"   ListId
-                      :> ReqBody '[JSON] NgramsIdPatchs
-                      :> Put     '[JSON] NgramsIdPatchsBack
 
 type TableNgramsApiGet = Summary " Table Ngrams API Get"
                       :> QueryParam "ngramsType"   TabType
                       :> QueryParam "list"   ListId
-                      :> Get    '[JSON] NgramsTable
-
-type NgramsIdPatchsFeed = NgramsIdPatchs
-type NgramsIdPatchsBack = NgramsIdPatchs
-
-
-defaultList :: Connection -> CorpusId -> IO ListId
-defaultList c cId = view node_id <$> maybe (panic noListFound) identity 
-  <$> head
-  <$> getListsWithParentId c cId
-  where
-    noListFound = "Gargantext.API.Ngrams.defaultList: no list found"
-
-toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
-toLists lId np = map (toList lId) (_nip_ngramsIdPatchs np)
+                      :> QueryParam "limit"  Limit
+                      :> QueryParam "offset" Offset
+                      :> Get    '[JSON] (Versioned NgramsTable)
 
-toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
-toList = undefined
--- toList lId (NgramsIdPatch ngId (NgramsPatch lt _ _)) = (lId,ngId,listTypeId lt)
-
-toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
-toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
-
-toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
-toGroup = undefined
-{-
-toGroup lId addOrRem (NgramsIdPatch ngId patch)  =
-  map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
--}
+type TableNgramsApi = Summary " Table Ngrams API Change"
+                      :> QueryParam "ngramsType"   TabType
+                      :> QueryParam "list"   ListId
+                      :> ReqBody '[JSON] (Versioned NgramsTablePatch)
+                      :> Put     '[JSON] (Versioned NgramsTablePatch)
+
+data NgramError = UnsupportedVersion
+  deriving (Show)
+
+class HasNgramError e where
+  _NgramError :: Prism' e NgramError
+
+instance HasNgramError ServantErr where
+  _NgramError = prism' make match
+    where
+      err = err500 { errBody = "NgramError: Unsupported version" }
+      make UnsupportedVersion = err
+      match e = guard (e == err) $> UnsupportedVersion
+
+ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
+ngramError nne = throwError $ _NgramError # nne
+
+-- TODO: Replace.old is ignored which means that if the current list
+-- `GraphList` and that the patch is `Replace CandidateList StopList` then
+-- the list is going to be `StopList` while it should keep `GraphList`.
+-- However this should not happen in non conflicting situations.
+mkListsUpdate :: ListId -> NgramsType -> NgramsTablePatch -> [(ListId, NgramsTypeId, NgramsTerm, ListTypeId)]
+mkListsUpdate lId nt patches =
+  [ (lId, ngramsTypeId nt, ng, listTypeId lt)
+  | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
+  , lt <- patch ^.. patch_list . new
+  ]
+
+mkChildrenGroups :: ListId
+                 -> (PatchSet NgramsTerm -> Set NgramsTerm)
+                 -> NgramsTablePatch
+                 -> [(ListId, NgramsParent, NgramsChild, Maybe Double)]
+mkChildrenGroups lId addOrRem patches =
+  [ (lId, parent, child, Just 1)
+  | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
+  , child <- patch ^.. patch_children . to addOrRem . folded
+  ]
+
+ngramsTypeFromTabType :: Maybe TabType -> NgramsType
+ngramsTypeFromTabType maybeTabType =
+  let lieu = "Garg.API.Ngrams: " :: Text in
+  case maybeTabType of
+        Nothing  -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
+        Just tab -> case tab of
+            Sources    -> Ngrams.Sources
+            Authors    -> Ngrams.Authors
+            Institutes -> Ngrams.Institutes
+            Terms      -> Ngrams.NgramsTerms
+            _          -> panic $ lieu <> "No Ngrams for this tab"
+
+
+-- Apply the given patch to the DB and returns the patch to be applied on the
+-- cilent.
+-- TODO:
+-- In this perliminary version the OT aspect is missing, therefore the version
+-- number is always 1 and the returned patch is always empty.
+tableNgramsPatch :: (HasNgramError err, HasNodeError err)
+                 => CorpusId -> Maybe TabType -> Maybe ListId
+                 -> Versioned NgramsTablePatch
+                 -> Cmd err (Versioned NgramsTablePatch)
+tableNgramsPatch corpusId maybeTabType maybeList (Versioned version patch) = do
+  when (version /= 1) $ ngramError UnsupportedVersion
+  let ngramsType = ngramsTypeFromTabType maybeTabType
+  listId <- maybe (defaultList corpusId) pure maybeList
+  updateNodeNgrams $ NodeNgramsUpdate
+    { _nnu_lists_update = mkListsUpdate listId ngramsType patch
+    , _nnu_rem_children = mkChildrenGroups listId _rem patch
+    , _nnu_add_children = mkChildrenGroups listId _add patch
+    }
+  pure $ Versioned 1 emptyNgramsTablePatch
+
+-- | TODO Errors management
+--  TODO: polymorphic for Annuaire or Corpus or ...
+getTableNgrams :: HasNodeError err
+               => CorpusId -> Maybe TabType
+               -> Maybe ListId -> Maybe Limit -> Maybe Offset
+               -> Cmd err (Versioned NgramsTable)
+getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
+  let lieu = "Garg.API.Ngrams: " :: Text
+  let ngramsType = ngramsTypeFromTabType maybeTabType
+  listId <- maybe (defaultList cId) pure maybeListId
+
+  let
+    defaultLimit = 10 -- TODO
+    limit_  = maybe defaultLimit identity mlimit
+    offset_ = maybe 0 identity moffset
+
+  (ngramsTableDatas, mapToParent, mapToChildren) <-
+    Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
+
+  -- printDebug "ngramsTableDatas" ngramsTableDatas
+
+  pure $ Versioned 1 $
+         NgramsTable $ map (\(Ngrams.NgramsTableData ngs _ lt w) ->
+                              NgramsElement ngs
+                                            (maybe (panic $ lieu <> "listType") identity lt)
+                                            (round w)
+                                            (lookup ngs mapToParent)
+                                            (maybe mempty identity $ lookup ngs mapToChildren)
+                           ) ngramsTableDatas
 
 
-tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
-tableNgramsPatch = undefined 
-{-
-tableNgramsPatch conn corpusId maybeList patchs = do
-  listId <- case maybeList of
-              Nothing      -> defaultList conn corpusId
-              Just listId' -> pure listId'
-  _ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
-  _ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
-  _ <- updateNodeNgrams conn (toLists listId patchs)
-  pure (NgramsIdPatchs [])
-  -}
-
-getTableNgramsPatch :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
-getTableNgramsPatch = undefined