src/Gargantext/API/Ngrams.hs

   1 {-|
   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
   8 Portability : POSIX
   9
  10 Ngrams API
  11
  12 -- | TODO
  13 get ngrams filtered by NgramsType
  14 add get
  15
  16 -}
  17
  18 {-# LANGUAGE ConstraintKinds   #-}
  19 {-# LANGUAGE DataKinds         #-}
  20 {-# LANGUAGE DeriveGeneric     #-}
  21 {-# LANGUAGE NoImplicitPrelude #-}
  22 {-# LANGUAGE OverloadedStrings #-}
  23 {-# LANGUAGE ScopedTypeVariables #-}
  24 {-# LANGUAGE TemplateHaskell   #-}
  25 {-# LANGUAGE TypeOperators     #-}
  26 {-# LANGUAGE FlexibleContexts  #-}
  27 {-# LANGUAGE FlexibleInstances #-}
  28 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  29 {-# LANGUAGE MultiParamTypeClasses #-}
  30 {-# LANGUAGE RankNTypes        #-}
  31 {-# LANGUAGE TypeFamilies      #-}
  32 {-# OPTIONS -fno-warn-orphans #-}
  33
  34 module Gargantext.API.Ngrams
  35   where
  36
  37 -- import Debug.Trace (trace)
  38 import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-}, error)
  39 -- import Gargantext.Database.Schema.User  (UserId)
  40 import Data.Patch.Class (Replace, replace, Action(act), Applicable(..),
  41                          Composable(..), Transformable(..),
  42                          PairPatch(..), Patched, ConflictResolution,
  43                          ConflictResolutionReplace, ours)
  44 import qualified Data.Map.Strict.Patch as PM
  45 import Data.Monoid
  46 import Data.Foldable
  47 --import Data.Semigroup
  48 import Data.Set (Set)
  49 -- import qualified Data.List as List
  50 import Data.Maybe (fromMaybe)
  51 -- import Data.Tuple.Extra (first)
  52 import qualified Data.Map.Strict as Map
  53 import Data.Map.Strict (Map)
  54 import qualified Data.Set as Set
  55 import Control.Category ((>>>))
  56 import Control.Concurrent
  57 import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, mapped, forOf_)
  58 import Control.Monad.Error.Class (MonadError)
  59 import Control.Monad.Reader
  60 import Control.Monad.State
  61 import Data.Aeson hiding ((.=))
  62 import Data.Aeson.TH (deriveJSON)
  63 import Data.Either(Either(Left))
  64 -- import Data.Map (lookup)
  65 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
  66 import Data.Swagger hiding (version, patch)
  67 import Data.Text (Text, isInfixOf, count)
  68 import Data.Validity
  69 import GHC.Generics (Generic)
  70 import Gargantext.Core.Utils.Prefix (unPrefix)
  71 -- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
  72 --import Gargantext.Database.Config (userMaster)
  73 import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlySafe)
  74 import Gargantext.Database.Schema.Ngrams (NgramsType)
  75 import Gargantext.Database.Utils (fromField', HasConnection)
  76 --import Gargantext.Database.Lists (listsWith)
  77 import Gargantext.Database.Schema.Node (HasNodeError)
  78 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
  79 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
  80 -- import Gargantext.Database.Schema.NodeNgram hiding (Action)
  81 import Gargantext.Prelude
  82 -- import Gargantext.Core.Types (ListTypeId, listTypeId)
  83 import Gargantext.Core.Types (ListType(..), NodeId, ListId, CorpusId, Limit, Offset, HasInvalidError, assertValid)
  84 import Servant hiding (Patch)
  85 import System.FileLock (FileLock)
  86 import Test.QuickCheck (elements)
  87 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  88
  89 data TODO = TODO
  90   deriving (Generic)
  91
  92 instance ToSchema TODO where
  93
  94 ------------------------------------------------------------------------
  95 --data FacetFormat = Table | Chart
  96 data TabType   = Docs     | Terms  | Sources | Authors | Institutes | Trash
  97                | Contacts
  98   deriving (Generic, Enum, Bounded)
  99
 100 instance FromHttpApiData TabType
 101   where
 102     parseUrlPiece "Docs"       = pure Docs
 103     parseUrlPiece "Terms"      = pure Terms
 104     parseUrlPiece "Sources"    = pure Sources
 105     parseUrlPiece "Institutes" = pure Institutes
 106     parseUrlPiece "Authors"    = pure Authors
 107     parseUrlPiece "Trash"      = pure Trash
 108
 109     parseUrlPiece "Contacts"   = pure Contacts
 110
 111     parseUrlPiece _            = Left "Unexpected value of TabType"
 112
 113 instance ToParamSchema   TabType
 114 instance ToJSON    TabType
 115 instance FromJSON  TabType
 116 instance ToSchema  TabType
 117 instance Arbitrary TabType
 118   where
 119     arbitrary = elements [minBound .. maxBound]
 120
 121 newtype MSet a = MSet (Map a ())
 122   deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
 123
 124 instance ToJSON a => ToJSON (MSet a) where
 125   toJSON     (MSet m) = toJSON     (Map.keys m)
 126   toEncoding (MSet m) = toEncoding (Map.keys m)
 127
 128 mSetFromSet :: Set a -> MSet a
 129 mSetFromSet = MSet . Map.fromSet (const ())
 130
 131 mSetFromList :: Ord a => [a] -> MSet a
 132 mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
 133
 134 instance Foldable MSet where
 135   foldMap f (MSet m) = Map.foldMapWithKey (\k _ -> f k) m
 136
 137 instance (Ord a, FromJSON a) => FromJSON (MSet a) where
 138   parseJSON = fmap mSetFromList . parseJSON
 139
 140 instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
 141   -- TODO
 142   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
 143
 144 ------------------------------------------------------------------------
 145 type NgramsTerm = Text
 146
 147 data RootParent = RootParent
 148   { _rp_root   :: NgramsTerm
 149   , _rp_parent :: NgramsTerm
 150   }
 151   deriving (Ord, Eq, Show, Generic)
 152
 153 deriveJSON (unPrefix "_rp_") ''RootParent
 154 makeLenses ''RootParent
 155
 156 data NgramsRepoElement = NgramsRepoElement
 157   { _nre_size        :: Int
 158   , _nre_list        :: ListType
 159 --, _nre_root_parent :: Maybe RootParent
 160   , _nre_root        :: Maybe NgramsTerm
 161   , _nre_parent      :: Maybe NgramsTerm
 162   , _nre_children    :: MSet NgramsTerm
 163   }
 164   deriving (Ord, Eq, Show, Generic)
 165
 166 deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
 167 makeLenses ''NgramsRepoElement
 168
 169 data NgramsElement =
 170      NgramsElement { _ne_ngrams      :: NgramsTerm
 171                    , _ne_size        :: Int
 172                    , _ne_list        :: ListType
 173                    , _ne_occurrences :: Int
 174                    , _ne_root        :: Maybe NgramsTerm
 175                    , _ne_parent      :: Maybe NgramsTerm
 176                    , _ne_children    :: MSet NgramsTerm
 177                    }
 178       deriving (Ord, Eq, Show, Generic)
 179
 180 deriveJSON (unPrefix "_ne_") ''NgramsElement
 181 makeLenses ''NgramsElement
 182
 183 mkNgramsElement :: NgramsTerm -> ListType -> Maybe RootParent -> MSet NgramsTerm -> NgramsElement
 184 mkNgramsElement ngrams list rp children =
 185   NgramsElement ngrams size list 1 (_rp_root <$> rp) (_rp_parent <$> rp) children
 186   where
 187     -- TODO review
 188     size = 1 + count " " ngrams
 189
 190 instance ToSchema NgramsElement
 191 instance Arbitrary NgramsElement where
 192   arbitrary = elements [mkNgramsElement "sport" GraphTerm Nothing mempty]
 193
 194 ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
 195 ngramsElementToRepo
 196   (NgramsElement { _ne_size = s
 197                  , _ne_list = l
 198                  , _ne_root = r
 199                  , _ne_parent = p
 200                  , _ne_children = c
 201                  }) =
 202   NgramsRepoElement
 203     { _nre_size = s
 204     , _nre_list = l
 205     , _nre_parent = p
 206     , _nre_root   = r
 207     , _nre_children = c
 208     }
 209
 210 ngramsElementFromRepo :: (NgramsTerm, NgramsRepoElement) -> NgramsElement
 211 ngramsElementFromRepo
 212   (ngrams,
 213    NgramsRepoElement
 214       { _nre_size = s
 215       , _nre_list = l
 216       , _nre_parent = p
 217       , _nre_root = r
 218       , _nre_children = c
 219       }) =
 220   NgramsElement { _ne_size = s
 221                 , _ne_list = l
 222                 , _ne_root = r
 223                 , _ne_parent = p
 224                 , _ne_children = c
 225                 , _ne_ngrams = ngrams
 226                 , _ne_occurrences = panic "API.Ngrams._ne_occurrences"
 227                 -- ^ Here we could use 0 if we want to avoid any `panic`.
 228                 -- It will not happen using getTableNgrams if
 229                 -- getOccByNgramsOnly provides a count of occurrences for
 230                 -- all the ngrams given.
 231                 }
 232
 233 ------------------------------------------------------------------------
 234 newtype NgramsTable = NgramsTable [NgramsElement]
 235   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 236
 237 type ListNgrams = NgramsTable
 238
 239 makePrisms ''NgramsTable
 240
 241 -- | Question: why these repetition of Type in this instance
 242 -- may you document it please ?
 243 instance Each NgramsTable NgramsTable NgramsElement NgramsElement where
 244   each = _NgramsTable . each
 245
 246 -- TODO discuss
 247 -- | TODO Check N and Weight
 248 {-
 249 toNgramsElement :: [NgramsTableData] -> [NgramsElement]
 250 toNgramsElement ns = map toNgramsElement' ns
 251     where
 252       toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
 253         where
 254           p' = case p of
 255                  Nothing -> Nothing
 256                  Just x  -> lookup x mapParent
 257           c' = maybe mempty identity $ lookup t mapChildren
 258           lt' = maybe (panic "API.Ngrams: listypeId") identity lt
 259
 260       mapParent :: Map Int Text
 261       mapParent   = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
 262
 263       mapChildren :: Map Text (Set Text)
 264       mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
 265                   $ Map.fromListWith (<>)
 266                   $ map (first fromJust)
 267                   $ filter (isJust . fst)
 268                   $ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
 269 -}
 270
 271 mockTable :: NgramsTable
 272 mockTable = NgramsTable
 273   [ mkNgramsElement "animal"  GraphTerm      Nothing       (mSetFromList ["dog", "cat"])
 274   , mkNgramsElement "cat"     GraphTerm     (rp "animal")  mempty
 275   , mkNgramsElement "cats"    StopTerm       Nothing       mempty
 276   , mkNgramsElement "dog"     GraphTerm     (rp "animal")  (mSetFromList ["dogs"])
 277   , mkNgramsElement "dogs"    StopTerm      (rp "dog")     mempty
 278   , mkNgramsElement "fox"     GraphTerm      Nothing       mempty
 279   , mkNgramsElement "object"  CandidateTerm  Nothing       mempty
 280   , mkNgramsElement "nothing" StopTerm       Nothing       mempty
 281   , mkNgramsElement "organic" GraphTerm      Nothing       (mSetFromList ["flower"])
 282   , mkNgramsElement "flower"  GraphTerm     (rp "organic") mempty
 283   , mkNgramsElement "moon"    CandidateTerm  Nothing       mempty
 284   , mkNgramsElement "sky"     StopTerm       Nothing       mempty
 285   ]
 286   where
 287     rp n = Just $ RootParent n n
 288
 289 instance Arbitrary NgramsTable where
 290   arbitrary = pure mockTable
 291
 292 instance ToSchema NgramsTable
 293
 294 ------------------------------------------------------------------------
 295 type NgramsTableMap = Map NgramsTerm NgramsRepoElement
 296
 297 ------------------------------------------------------------------------
 298 -- On the Client side:
 299 --data Action = InGroup     NgramsId NgramsId
 300 --            | OutGroup    NgramsId NgramsId
 301 --            | SetListType NgramsId ListType
 302
 303 data PatchSet a = PatchSet
 304   { _rem :: Set a
 305   , _add :: Set a
 306   }
 307   deriving (Eq, Ord, Show, Generic)
 308
 309 makeLenses ''PatchSet
 310 makePrisms ''PatchSet
 311
 312 instance ToJSON a => ToJSON (PatchSet a) where
 313   toJSON     = genericToJSON     $ unPrefix "_"
 314   toEncoding = genericToEncoding $ unPrefix "_"
 315
 316 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
 317   parseJSON = genericParseJSON $ unPrefix "_"
 318
 319 {-
 320 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 321   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 322
 323 type instance Patched (PatchSet a) = Set a
 324
 325 type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
 326 type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
 327
 328 instance Ord a => Semigroup (PatchSet a) where
 329   p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem
 330                     , _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add
 331                     } -- TODO Review
 332
 333 instance Ord a => Monoid (PatchSet a) where
 334   mempty = PatchSet mempty mempty
 335
 336 instance Ord a => Group (PatchSet a) where
 337   invert (PatchSet r a) = PatchSet a r
 338
 339 instance Ord a => Composable (PatchSet a) where
 340   composable _ _ = undefined
 341
 342 instance Ord a => Action (PatchSet a) (Set a) where
 343   act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
 344
 345 instance Applicable (PatchSet a) (Set a) where
 346   applicable _ _ = mempty
 347
 348 instance Ord a => Validity (PatchSet a) where
 349   validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
 350
 351 instance Ord a => Transformable (PatchSet a) where
 352   transformable = undefined
 353
 354   conflicts _p _q = undefined
 355
 356   transformWith conflict p q = undefined conflict p q
 357
 358 instance ToSchema a => ToSchema (PatchSet a)
 359 -}
 360
 361 type AddRem = Replace (Maybe ())
 362
 363 remPatch, addPatch :: AddRem
 364 remPatch = replace (Just ()) Nothing
 365 addPatch = replace Nothing (Just ())
 366
 367 isRem :: Replace (Maybe ()) -> Bool
 368 isRem = (== remPatch)
 369
 370 type PatchMap = PM.PatchMap
 371
 372 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
 373   deriving (Eq, Show, Generic, Validity, Semigroup, Monoid,
 374             Transformable, Composable)
 375
 376 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
 377 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
 378
 379 -- TODO this breaks module abstraction
 380 makePrisms ''PM.PatchMap
 381
 382 makePrisms ''PatchMSet
 383
 384 _PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
 385 _PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
 386   where
 387     f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
 388     f = Map.partition isRem >>> both %~ Map.keysSet
 389
 390     g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
 391     g (rems, adds) = Map.fromSet (const remPatch) rems
 392                   <> Map.fromSet (const addPatch) adds
 393
 394 instance Ord a => Action (PatchMSet a) (MSet a) where
 395   act (PatchMSet p) (MSet m) = MSet $ act p m
 396
 397 instance Ord a => Applicable (PatchMSet a) (MSet a) where
 398   applicable (PatchMSet p) (MSet m) = applicable p m
 399
 400 instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
 401   toJSON     = toJSON . view _PatchMSetIso
 402   toEncoding = toEncoding . view _PatchMSetIso
 403
 404 instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
 405   parseJSON = fmap (_PatchMSetIso #) . parseJSON
 406
 407 instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
 408   arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
 409
 410 instance ToSchema a => ToSchema (PatchMSet a) where
 411   -- TODO
 412   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
 413
 414 type instance Patched (PatchMSet a) = MSet a
 415
 416 instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
 417   arbitrary = uncurry replace <$> arbitrary
 418     -- If they happen to be equal then the patch is Keep.
 419
 420 instance ToSchema a => ToSchema (Replace a) where
 421   declareNamedSchema (_ :: proxy (Replace a)) = do
 422     -- TODO Keep constructor is not supported here.
 423     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 424     return $ NamedSchema (Just "Replace") $ mempty
 425       & type_ .~ SwaggerObject
 426       & properties .~
 427           InsOrdHashMap.fromList
 428           [ ("old", aSchema)
 429           , ("new", aSchema)
 430           ]
 431       & required .~ [ "old", "new" ]
 432
 433 data NgramsPatch =
 434      NgramsPatch { _patch_children :: PatchMSet NgramsTerm
 435                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
 436                  }
 437       deriving (Eq, Show, Generic)
 438
 439 deriveJSON (unPrefix "_") ''NgramsPatch
 440 makeLenses ''NgramsPatch
 441
 442 instance ToSchema  NgramsPatch
 443
 444 instance Arbitrary NgramsPatch where
 445   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 446
 447 type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType)
 448
 449 _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
 450 _NgramsPatch = iso (\(NgramsPatch c l) -> c :*: l) (\(c :*: l) -> NgramsPatch c l)
 451
 452 instance Semigroup NgramsPatch where
 453   p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
 454
 455 instance Monoid NgramsPatch where
 456   mempty = _NgramsPatch # mempty
 457
 458 instance Validity NgramsPatch where
 459   validate p = p ^. _NgramsPatch . to validate
 460
 461 instance Transformable NgramsPatch where
 462   transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 463
 464   conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 465
 466   transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
 467     where
 468       (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 469
 470 type ConflictResolutionNgramsPatch =
 471   ( ConflictResolutionPatchMSet NgramsTerm
 472   , ConflictResolutionReplace ListType
 473   )
 474 type instance ConflictResolution NgramsPatch =
 475   ConflictResolutionNgramsPatch
 476
 477 type PatchedNgramsPatch = (Set NgramsTerm, ListType)
 478   -- ~ Patched NgramsPatchIso
 479 type instance Patched NgramsPatch = PatchedNgramsPatch
 480
 481 instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
 482   applicable p Nothing   = check (p == mempty) "NgramsPatch should be empty here"
 483   applicable p (Just nre) =
 484     applicable (p ^. patch_children) (nre ^. nre_children) <>
 485     applicable (p ^. patch_list)     (nre ^. nre_list)
 486
 487 instance Action NgramsPatch NgramsRepoElement where
 488   act p = (nre_children %~ act (p ^. patch_children))
 489         . (nre_list     %~ act (p ^. patch_list))
 490
 491 instance Action NgramsPatch (Maybe NgramsRepoElement) where
 492   act = fmap . act
 493
 494 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
 495   deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
 496
 497 instance FromField NgramsTablePatch
 498   where
 499     fromField = fromField'
 500
 501 instance FromField (PatchMap NgramsType (PatchMap NodeId NgramsTablePatch))
 502   where
 503     fromField = fromField'
 504
 505 --instance (Ord k, Action pv (Maybe v)) => Action (PatchMap k pv) (Map k v) where
 506 --
 507 type instance ConflictResolution NgramsTablePatch =
 508   NgramsTerm -> ConflictResolutionNgramsPatch
 509
 510 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
 511   -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
 512 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
 513
 514 makePrisms ''NgramsTablePatch
 515 instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
 516 instance ToSchema  NgramsTablePatch
 517
 518 instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
 519   applicable p = applicable (p ^. _NgramsTablePatch)
 520
 521 instance Action NgramsTablePatch (Maybe NgramsTableMap) where
 522   act p =
 523     fmap (execState (reParentNgramsTablePatch p)) .
 524     act (p ^. _NgramsTablePatch)
 525
 526 instance Arbitrary NgramsTablePatch where
 527   arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
 528
 529 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
 530 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
 531 -- ntp_ngrams_patches = _NgramsTablePatch .  undefined
 532
 533 type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
 534
 535 reRootChildren :: NgramsTerm -> ReParent NgramsTerm
 536 reRootChildren root ngram = do
 537   nre <- use $ at ngram
 538   forOf_ (_Just . nre_children . folded) nre $ \child -> do
 539     at child . _Just . nre_root ?= root
 540     reRootChildren root child
 541
 542 reParent :: Maybe RootParent -> ReParent NgramsTerm
 543 reParent rp child = do
 544   at child . _Just %= ( (nre_parent .~ (_rp_parent <$> rp))
 545                       . (nre_root   .~ (_rp_root   <$> rp))
 546                       )
 547   reRootChildren (fromMaybe child (rp ^? _Just . rp_root)) child
 548
 549 reParentAddRem :: RootParent -> NgramsTerm -> ReParent AddRem
 550 reParentAddRem rp child p =
 551   reParent (if isRem p then Nothing else Just rp) child
 552
 553 reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
 554 reParentNgramsPatch parent ngramsPatch = do
 555   root_of_parent <- use (at parent . _Just . nre_root)
 556   let
 557     root = fromMaybe parent root_of_parent
 558     rp   = RootParent { _rp_root = root, _rp_parent = parent }
 559   itraverse_ (reParentAddRem rp) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
 560   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 561
 562 reParentNgramsTablePatch :: ReParent NgramsTablePatch
 563 reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
 564   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 565
 566 ------------------------------------------------------------------------
 567 ------------------------------------------------------------------------
 568 type Version = Int
 569
 570 data Versioned a = Versioned
 571   { _v_version :: Version
 572   , _v_data    :: a
 573   }
 574   deriving (Generic, Show)
 575 deriveJSON (unPrefix "_v_") ''Versioned
 576 makeLenses ''Versioned
 577 instance ToSchema a => ToSchema (Versioned a)
 578 instance Arbitrary a => Arbitrary (Versioned a) where
 579   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 580
 581 {-
 582 -- TODO sequencs of modifications (Patchs)
 583 type NgramsIdPatch = Patch NgramsId NgramsPatch
 584
 585 ngramsPatch :: Int -> NgramsPatch
 586 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopTerm)]) (Set.fromList [n]) Set.empty
 587
 588 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 589 toEdit n p = Edit n p
 590 ngramsIdPatch :: Patch NgramsId NgramsPatch
 591 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 592                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 593                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 594                                        ]
 595
 596 -- applyPatchBack :: Patch -> IO Patch
 597 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 598 -}
 599 ------------------------------------------------------------------------
 600 ------------------------------------------------------------------------
 601 ------------------------------------------------------------------------
 602
 603 -- TODO: find a better place for this Gargantext.API.{Common|Prelude|Core} ?
 604 type QueryParamR = QueryParam' '[Required, Strict]
 605
 606 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 607                       :> QueryParamR "ngramsType"  TabType
 608                       :> QueryParamR "list"        ListId
 609                       :> QueryParamR "limit"       Limit
 610                       :> QueryParam  "offset"      Offset
 611                       :> QueryParam  "listType"    ListType
 612                       :> QueryParam  "minTermSize" Int
 613                       :> QueryParam  "maxTermSize" Int
 614                       :> QueryParam  "search"      Text
 615                       :> Get    '[JSON] (Versioned NgramsTable)
 616
 617 type TableNgramsApi = Summary " Table Ngrams API Change"
 618                       :> QueryParamR "ngramsType" TabType
 619                       :> QueryParamR "list"       ListId
 620                       :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 621                       :> Put     '[JSON] (Versioned NgramsTablePatch)
 622
 623 {-
 624 -- TODO: Replace.old is ignored which means that if the current list
 625 -- `GraphTerm` and that the patch is `Replace CandidateTerm StopTerm` then
 626 -- the list is going to be `StopTerm` while it should keep `GraphTerm`.
 627 -- However this should not happen in non conflicting situations.
 628 mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
 629 mkListsUpdate nt patches =
 630   [ (ngramsTypeId nt, ng, listTypeId lt)
 631   | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 632   , lt <- patch ^.. patch_list . new
 633   ]
 634
 635 mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm)
 636                  -> NgramsType
 637                  -> NgramsTablePatch
 638                  -> [(NgramsTypeId, NgramsParent, NgramsChild)]
 639 mkChildrenGroups addOrRem nt patches =
 640   [ (ngramsTypeId nt, parent, child)
 641   | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 642   , child <- patch ^.. patch_children . to addOrRem . folded
 643   ]
 644 -}
 645
 646 ngramsTypeFromTabType :: TabType -> NgramsType
 647 ngramsTypeFromTabType tabType =
 648   let lieu = "Garg.API.Ngrams: " :: Text in
 649     case tabType of
 650       Sources    -> Ngrams.Sources
 651       Authors    -> Ngrams.Authors
 652       Institutes -> Ngrams.Institutes
 653       Terms      -> Ngrams.NgramsTerms
 654       _          -> panic $ lieu <> "No Ngrams for this tab"
 655       -- ^ TODO: This `panic` would disapear with custom NgramsType.
 656
 657 ------------------------------------------------------------------------
 658 data Repo s p = Repo
 659   { _r_version :: Version
 660   , _r_state   :: s
 661   , _r_history :: [p]
 662     -- ^ first patch in the list is the most recent
 663   }
 664   deriving (Generic)
 665
 666 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
 667   parseJSON = genericParseJSON $ unPrefix "_r_"
 668
 669 instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
 670   toJSON     = genericToJSON     $ unPrefix "_r_"
 671   toEncoding = genericToEncoding $ unPrefix "_r_"
 672
 673 makeLenses ''Repo
 674
 675 initRepo :: Monoid s => Repo s p
 676 initRepo = Repo 1 mempty []
 677
 678 type NgramsRepo       = Repo NgramsState NgramsStatePatch
 679 type NgramsState      = Map NgramsType (Map NodeId NgramsTableMap)
 680 type NgramsStatePatch = PatchMap NgramsType (PatchMap NodeId NgramsTablePatch)
 681
 682 initMockRepo :: NgramsRepo
 683 initMockRepo = Repo 1 s []
 684   where
 685     s = Map.singleton Ngrams.NgramsTerms
 686       $ Map.singleton 47254
 687       $ Map.fromList
 688       [ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ]
 689
 690 data RepoEnv = RepoEnv
 691   { _renv_var   :: !(MVar NgramsRepo)
 692   , _renv_saver :: !(IO ())
 693   , _renv_lock  :: !FileLock
 694   }
 695   deriving (Generic)
 696
 697 makeLenses ''RepoEnv
 698
 699 class HasRepoVar env where
 700   repoVar :: Getter env (MVar NgramsRepo)
 701
 702 instance HasRepoVar (MVar NgramsRepo) where
 703   repoVar = identity
 704
 705 class HasRepoSaver env where
 706   repoSaver :: Getter env (IO ())
 707
 708 class (HasRepoVar env, HasRepoSaver env) => HasRepo env where
 709   repoEnv :: Getter env RepoEnv
 710
 711 instance HasRepo RepoEnv where
 712   repoEnv = identity
 713
 714 instance HasRepoVar RepoEnv where
 715   repoVar = renv_var
 716
 717 instance HasRepoSaver RepoEnv where
 718   repoSaver = renv_saver
 719
 720 type RepoCmdM env err m =
 721   ( MonadReader env m
 722   , MonadError err m
 723   , MonadIO m
 724   , HasRepo env
 725   )
 726 ------------------------------------------------------------------------
 727
 728 saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env )
 729          => m ()
 730 saveRepo = liftIO =<< view repoSaver
 731
 732 listTypeConflictResolution :: ListType -> ListType -> ListType
 733 listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
 734
 735 ngramsStatePatchConflictResolution
 736   :: NgramsType -> NodeId -> NgramsTerm
 737   -> ConflictResolutionNgramsPatch
 738 ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
 739   = (const ours, ours)
 740   -- undefined {- TODO think this through -}, listTypeConflictResolution)
 741
 742 -- Current state:
 743 --   Insertions are not considered as patches,
 744 --   they do not extend history,
 745 --   they do not bump version.
 746 insertNewOnly :: a -> Maybe b -> a
 747 insertNewOnly m = maybe m (const $ error "insertNewOnly: impossible")
 748   -- TODO error handling
 749
 750 something :: Monoid a => Maybe a -> a
 751 something Nothing  = mempty
 752 something (Just a) = a
 753
 754 {- unused
 755 -- TODO refactor with putListNgrams
 756 copyListNgrams :: RepoCmdM env err m
 757                => NodeId -> NodeId -> NgramsType
 758                -> m ()
 759 copyListNgrams srcListId dstListId ngramsType = do
 760   var <- view repoVar
 761   liftIO $ modifyMVar_ var $
 762     pure . (r_state . at ngramsType %~ (Just . f . something))
 763   saveRepo
 764   where
 765     f :: Map NodeId NgramsTableMap -> Map NodeId NgramsTableMap
 766     f m = m & at dstListId %~ insertNewOnly (m ^. at srcListId)
 767
 768 -- TODO refactor with putListNgrams
 769 -- The list must be non-empty!
 770 -- The added ngrams must be non-existent!
 771 addListNgrams :: RepoCmdM env err m
 772               => NodeId -> NgramsType
 773               -> [NgramsElement] -> m ()
 774 addListNgrams listId ngramsType nes = do
 775   var <- view repoVar
 776   liftIO $ modifyMVar_ var $
 777     pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
 778   saveRepo
 779   where
 780     m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
 781 -}
 782
 783 putListNgrams :: RepoCmdM env err m
 784               => NodeId -> NgramsType
 785               -> [NgramsElement] -> m ()
 786 putListNgrams _ _ [] = pure ()
 787 putListNgrams listId ngramsType nes = do
 788   -- printDebug "putListNgrams" (length nes)
 789   var <- view repoVar
 790   liftIO $ modifyMVar_ var $
 791     pure . (r_state . at ngramsType %~ (Just . (at listId %~ (Just . (m <>) . something)) . something))
 792   saveRepo
 793   where
 794     m = Map.fromList $ (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) <$> nes
 795
 796 -- Apply the given patch to the DB and returns the patch to be applied on the
 797 -- client.
 798 tableNgramsPatch :: (HasInvalidError err, RepoCmdM env err m)
 799                  => CorpusId -> TabType -> ListId
 800                  -> Versioned NgramsTablePatch
 801                  -> m (Versioned NgramsTablePatch)
 802 tableNgramsPatch _corpusId tabType listId (Versioned p_version p_table)
 803   | p_table == mempty = do
 804       let ngramsType        = ngramsTypeFromTabType tabType
 805
 806       var <- view repoVar
 807       r <- liftIO $ readMVar var
 808
 809       let
 810         q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 811         q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
 812
 813       pure (Versioned (r ^. r_version) q_table)
 814
 815   | otherwise         = do
 816       let ngramsType        = ngramsTypeFromTabType tabType
 817           (p0, p0_validity) = PM.singleton listId p_table
 818           (p, p_validity)   = PM.singleton ngramsType p0
 819
 820       assertValid p0_validity
 821       assertValid p_validity
 822
 823       var <- view repoVar
 824       vq' <- liftIO $ modifyMVar var $ \r -> do
 825         let
 826           q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 827           (p', q') = transformWith ngramsStatePatchConflictResolution p q
 828           r' = r & r_version +~ 1
 829                 & r_state   %~ act p'
 830                 & r_history %~ (p' :)
 831           q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
 832         {-
 833         -- Ideally we would like to check these properties. However:
 834         -- * They should be checked only to debug the code. The client data
 835         --   should be able to trigger these.
 836         -- * What kind of error should they throw (we are in IO here)?
 837         -- * Should we keep modifyMVar?
 838         -- * Should we throw the validation in an Exception, catch it around
 839         --   modifyMVar and throw it back as an Error?
 840         assertValid $ transformable p q
 841         assertValid $ applicable p' (r ^. r_state)
 842         -}
 843         pure (r', Versioned (r' ^. r_version) q'_table)
 844
 845       saveRepo
 846       pure vq'
 847
 848 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
 849 mergeNgramsElement _neOld neNew = neNew
 850   {-
 851   { _ne_list        :: ListType
 852   If we merge the parents/children we can potentially create cycles!
 853   , _ne_parent      :: Maybe NgramsTerm
 854   , _ne_children    :: MSet NgramsTerm
 855   }
 856   -}
 857
 858 getNgramsTableMap :: RepoCmdM env err m
 859                   => NodeId -> NgramsType -> m (Versioned NgramsTableMap)
 860 getNgramsTableMap nodeId ngramsType = do
 861   v <- view repoVar
 862   repo <- liftIO $ readMVar v
 863   pure $ Versioned (repo ^. r_version)
 864                    (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
 865
 866 type MinSize = Int
 867 type MaxSize = Int
 868
 869 -- | TODO Errors management
 870 --  TODO: polymorphic for Annuaire or Corpus or ...
 871 -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
 872 -- TODO: should take only one ListId
 873 getTableNgrams :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
 874                => CorpusId -> TabType
 875                -> ListId -> Limit -> Maybe Offset
 876                -> Maybe ListType
 877                -> Maybe MinSize -> Maybe MaxSize
 878                -> Maybe Text -- full text search
 879                -> m (Versioned NgramsTable)
 880 getTableNgrams cId tabType listId limit_ moffset
 881                mlistType mminSize mmaxSize msearchQuery = do
 882   let ngramsType = ngramsTypeFromTabType tabType
 883
 884   let
 885     offset_  = maybe 0 identity moffset
 886     listType = maybe (const True) (==) mlistType
 887     minSize  = maybe (const True) (<=) mminSize
 888     maxSize  = maybe (const True) (>=) mmaxSize
 889     searchQuery = maybe (const True) isInfixOf msearchQuery
 890     selected_node n = minSize     s
 891                    && maxSize     s
 892                    && searchQuery (n ^. ne_ngrams)
 893                    && listType    (n ^. ne_list)
 894       where
 895         s = n ^. ne_size
 896
 897     selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
 898
 899     finalize tableMap = NgramsTable $ roots <> inners
 900       where
 901         rootOf ne = maybe ne (\r -> ngramsElementFromRepo (r, fromMaybe (panic "getTableNgrams: invalid root") (tableMap ^. at r)))
 902                              (ne ^. ne_root)
 903         list = ngramsElementFromRepo <$> Map.toList tableMap
 904         selected_nodes = list & take limit_ . drop offset_ . filter selected_node
 905         roots = rootOf <$> selected_nodes
 906         rootsSet = Set.fromList (_ne_ngrams <$> roots)
 907         inners = list & filter (selected_inner rootsSet)
 908
 909   -- lists <- catMaybes <$> listsWith userMaster
 910   -- trace (show lists) $
 911   -- getNgramsTableMap ({-lists <>-} listIds) ngramsType
 912
 913   table <- getNgramsTableMap listId ngramsType & mapped . v_data %~ finalize
 914   occurrences <- getOccByNgramsOnlySafe cId ngramsType (table ^.. v_data . _NgramsTable . each . ne_ngrams)
 915
 916   let
 917     setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
 918
 919   pure $ table & v_data . _NgramsTable . each %~ setOcc
 920
 921
 922