2 Module : Gargantext.API.Ngrams
3 Description : Server API
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
13 get ngrams filtered by NgramsType
18 {-# LANGUAGE DataKinds #-}
19 {-# LANGUAGE DeriveGeneric #-}
20 {-# LANGUAGE NoImplicitPrelude #-}
21 {-# LANGUAGE OverloadedStrings #-}
22 {-# LANGUAGE ScopedTypeVariables #-}
23 {-# LANGUAGE TemplateHaskell #-}
24 {-# LANGUAGE TypeOperators #-}
25 {-# LANGUAGE FlexibleInstances #-}
26 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
27 {-# LANGUAGE RankNTypes #-}
28 {-# OPTIONS -fno-warn-orphans #-}
30 module Gargantext.API.Ngrams
33 import Prelude (round)
34 -- import Gargantext.Database.Schema.User (UserId)
35 import Data.Functor (($>))
36 import Data.Patch.Class (Replace, replace, new)
37 --import qualified Data.Map.Strict.Patch as PM
39 --import Data.Semigroup
41 import qualified Data.Set as Set
42 --import Data.Maybe (catMaybes)
43 -- import qualified Data.Map.Strict as DM
44 import Data.Map.Strict (Map)
45 --import qualified Data.Set as Set
46 import Control.Lens (makeLenses, Prism', prism', (^..), (^?), (.~), (#), to, each, withIndex, folded, ifolded)
47 import Control.Monad (guard, void)
48 import Control.Monad.Error.Class (MonadError, throwError)
50 import Data.Aeson.TH (deriveJSON)
51 import Data.Either(Either(Left))
52 import Data.Map (lookup)
53 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
54 import Data.Swagger hiding (version)
55 import Data.Text (Text)
56 import GHC.Generics (Generic)
57 import Gargantext.Core.Utils.Prefix (unPrefix)
58 import Gargantext.Database.Types.Node (NodeType(..))
59 import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
60 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
61 import Gargantext.Database.Schema.NodeNgram
62 import Gargantext.Database.Schema.NodeNgramsNgrams
63 import Gargantext.Database.Utils (Cmd)
64 import Gargantext.Prelude
65 import Gargantext.Core.Types (ListType(..), ListTypeId, ListId, CorpusId, Limit, Offset, listTypeId)
66 import Prelude (Enum, Bounded, minBound, maxBound)
67 import Servant hiding (Patch)
68 import Test.QuickCheck (elements)
69 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
71 ------------------------------------------------------------------------
72 --data FacetFormat = Table | Chart
73 data TabType = Docs | Terms | Sources | Authors | Institutes | Trash
75 deriving (Generic, Enum, Bounded)
77 instance FromHttpApiData TabType
79 parseUrlPiece "Docs" = pure Docs
80 parseUrlPiece "Terms" = pure Terms
81 parseUrlPiece "Sources" = pure Sources
82 parseUrlPiece "Institutes" = pure Institutes
83 parseUrlPiece "Authors" = pure Authors
84 parseUrlPiece "Trash" = pure Trash
86 parseUrlPiece "Contacts" = pure Contacts
88 parseUrlPiece _ = Left "Unexpected value of TabType"
90 instance ToParamSchema TabType
91 instance ToJSON TabType
92 instance FromJSON TabType
93 instance ToSchema TabType
94 instance Arbitrary TabType
96 arbitrary = elements [minBound .. maxBound]
98 ------------------------------------------------------------------------
99 type NgramsTerm = Text
102 NgramsElement { _ne_ngrams :: NgramsTerm
103 , _ne_list :: ListType
104 , _ne_occurrences :: Int
105 , _ne_parent :: Maybe NgramsTerm
106 , _ne_children :: Set NgramsTerm
108 deriving (Ord, Eq, Show, Generic)
110 deriveJSON (unPrefix "_ne_") ''NgramsElement
111 makeLenses ''NgramsElement
113 instance ToSchema NgramsElement
114 instance Arbitrary NgramsElement where
115 arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
117 ------------------------------------------------------------------------
118 newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
119 deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
121 instance Arbitrary NgramsTable where
124 [ NgramsElement "animal" GraphList 1 Nothing (Set.fromList ["dog", "cat"])
125 , NgramsElement "cat" GraphList 1 (Just "animal") mempty
126 , NgramsElement "cats" StopList 4 Nothing mempty
127 , NgramsElement "dog" GraphList 3 (Just "animal")(Set.fromList ["dogs"])
128 , NgramsElement "dogs" StopList 4 (Just "dog") mempty
129 , NgramsElement "fox" GraphList 1 Nothing mempty
130 , NgramsElement "object" CandidateList 2 Nothing mempty
131 , NgramsElement "nothing" StopList 4 Nothing mempty
132 , NgramsElement "organic" GraphList 3 Nothing (Set.singleton "flower")
133 , NgramsElement "flower" GraphList 3 (Just "organic") mempty
134 , NgramsElement "moon" CandidateList 1 Nothing mempty
135 , NgramsElement "sky" StopList 1 Nothing mempty
138 instance ToSchema NgramsTable
140 ------------------------------------------------------------------------
141 -- On the Client side:
142 --data Action = InGroup NgramsId NgramsId
143 -- | OutGroup NgramsId NgramsId
144 -- | SetListType NgramsId ListType
146 data PatchSet a = PatchSet
150 deriving (Eq, Ord, Show, Generic)
152 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
153 arbitrary = PatchSet <$> arbitrary <*> arbitrary
155 instance ToJSON a => ToJSON (PatchSet a) where
156 toJSON = genericToJSON $ unPrefix "_"
157 toEncoding = genericToEncoding $ unPrefix "_"
159 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
160 parseJSON = genericParseJSON $ unPrefix "_"
162 instance ToSchema a => ToSchema (PatchSet a)
164 instance ToSchema a => ToSchema (Replace a) where
165 declareNamedSchema (_ :: proxy (Replace a)) = do
166 aSchema <- declareSchemaRef (Proxy :: Proxy a)
167 return $ NamedSchema (Just "Replace") $ mempty
168 & type_ .~ SwaggerObject
170 InsOrdHashMap.fromList
174 & required .~ [ "old", "new" ]
177 NgramsPatch { _patch_children :: PatchSet NgramsElement
178 , _patch_list :: Replace ListType -- TODO Map UserId ListType
180 deriving (Ord, Eq, Show, Generic)
181 deriveJSON (unPrefix "_") ''NgramsPatch
182 makeLenses ''NgramsPatch
184 -- instance Semigroup NgramsPatch where
186 instance ToSchema NgramsPatch
188 instance Arbitrary NgramsPatch where
189 arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
191 newtype NgramsTablePatch =
192 NgramsTablePatch { _ntp_ngrams_patches :: Map NgramsTerm NgramsPatch }
193 deriving (Ord, Eq, Show, Generic, Arbitrary)
194 deriveJSON (unPrefix "_ntp_") ''NgramsTablePatch
195 makeLenses ''NgramsTablePatch
196 instance ToSchema NgramsTablePatch
198 -- TODO: replace by mempty once we have the Monoid instance
199 emptyNgramsTablePatch :: NgramsTablePatch
200 emptyNgramsTablePatch = NgramsTablePatch mempty
202 ------------------------------------------------------------------------
203 ------------------------------------------------------------------------
206 data Versioned a = Versioned
207 { _v_version :: Version
211 deriveJSON (unPrefix "_v_") ''Versioned
212 makeLenses ''Versioned
213 instance ToSchema a => ToSchema (Versioned a)
214 instance Arbitrary a => Arbitrary (Versioned a) where
215 arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
218 -- TODO sequencs of modifications (Patchs)
219 type NgramsIdPatch = Patch NgramsId NgramsPatch
221 ngramsPatch :: Int -> NgramsPatch
222 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
224 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
225 toEdit n p = Edit n p
226 ngramsIdPatch :: Patch NgramsId NgramsPatch
227 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
228 , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
229 , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
232 -- applyPatchBack :: Patch -> IO Patch
233 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
235 ------------------------------------------------------------------------
236 ------------------------------------------------------------------------
237 ------------------------------------------------------------------------
239 type TableNgramsApiGet = Summary " Table Ngrams API Get"
240 :> QueryParam "ngramsType" TabType
241 :> QueryParam "list" ListId
242 :> QueryParam "limit" Limit
243 :> QueryParam "offset" Offset
244 :> Get '[JSON] (Versioned NgramsTable)
246 type TableNgramsApi = Summary " Table Ngrams API Change"
247 :> QueryParam "list" ListId
248 :> ReqBody '[JSON] (Versioned NgramsTablePatch)
249 :> Put '[JSON] (Versioned NgramsTablePatch)
251 data NgramError = UnsupportedVersion
254 class HasNgramError e where
255 _NgramError :: Prism' e NgramError
257 instance HasNgramError ServantErr where
258 _NgramError = prism' make match
260 err = err500 { errBody = "NgramError: Unsupported version" }
261 make UnsupportedVersion = err
262 match e = guard (e == err) $> UnsupportedVersion
264 ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
265 ngramError nne = throwError $ _NgramError # nne
267 -- TODO: Replace.old is ignored which means that if the current list
268 -- `GraphList` and that the patch is `Replace CandidateList StopList` then
269 -- the list is going to be `StopList` while it should keep `GraphList`.
270 -- However this should not happen in non conflicting situations.
271 mkListsUpdate :: ListId -> NgramsTablePatch -> [(ListId, NgramsTerm, ListTypeId)]
272 mkListsUpdate lId patches =
273 [ (lId, ng, listTypeId lt)
274 | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
275 , let (Just lt) = patch ^? patch_list . new
278 mkChildrenGroups :: ListId
279 -> (PatchSet NgramsElement -> Set NgramsElement)
281 -> [(ListId, NgramsParent, NgramsChild, Maybe Double)]
282 mkChildrenGroups lId addOrRem patches =
283 [ (lId, parent, child, Just 1)
284 | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
285 , child <- patch ^.. patch_children . to addOrRem . folded . ne_ngrams
288 -- Apply the given patch to the DB and returns the patch to be applied on the
291 -- In this perliminary version the OT aspect is missing, therefore the version
292 -- number is always 1 and the returned patch is always empty.
293 tableNgramsPatch :: (HasNgramError err, HasNodeError err)
294 => CorpusId -> Maybe ListId
295 -> Versioned NgramsTablePatch
296 -> Cmd err (Versioned NgramsTablePatch)
297 tableNgramsPatch corpusId maybeList (Versioned version patch) = do
298 when (version /= 1) $ ngramError UnsupportedVersion
299 listId <- maybe (defaultList corpusId) pure maybeList
300 void $ updateNodeNgrams $ NodeNgramsUpdate
301 { _nnu_lists_update = mkListsUpdate listId patch
302 , _nnu_rem_children = mkChildrenGroups listId _rem patch
303 , _nnu_add_children = mkChildrenGroups listId _add patch
305 pure $ Versioned 1 emptyNgramsTablePatch
307 -- | TODO Errors management
308 -- TODO: polymorphic for Annuaire or Corpus or ...
309 getTableNgrams :: HasNodeError err
310 => CorpusId -> Maybe TabType
311 -> Maybe ListId -> Maybe Limit -> Maybe Offset
312 -> Cmd err (Versioned NgramsTable)
313 getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
314 let lieu = "Garg.API.Ngrams: " :: Text
315 let ngramsType = case maybeTabType of
316 Nothing -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
317 Just tab -> case tab of
318 Sources -> Ngrams.Sources
319 Authors -> Ngrams.Authors
320 Institutes -> Ngrams.Institutes
321 Terms -> Ngrams.NgramsTerms
322 _ -> panic $ lieu <> "No Ngrams for this tab"
324 listId <- maybe (defaultList cId) pure maybeListId
327 defaultLimit = 10 -- TODO
328 limit_ = maybe defaultLimit identity mlimit
329 offset_ = maybe 0 identity moffset
331 (ngramsTableDatas, mapToParent, mapToChildren) <-
332 Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
334 -- printDebug "ngramsTableDatas" ngramsTableDatas
337 NgramsTable $ map (\(Ngrams.NgramsTableData ngs _ lt w) ->
339 (maybe (panic $ lieu <> "listType") identity lt)
341 (lookup ngs mapToParent)
342 (maybe mempty identity $ lookup ngs mapToChildren)