src/Gargantext/API/Ngrams.hs

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