+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-|
Module : Gargantext.API.Ngrams
Description : Server API
-}
+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -fno-warn-orphans #-}
module Gargantext.API.Ngrams
+ ( TableNgramsApi
+ , TableNgramsApiGet
+ , TableNgramsApiPut
+ , TableNgramsApiPost
+
+ , getTableNgrams
+ , putListNgrams
+ , tableNgramsPost
+ , apiNgramsTableCorpus
+ , apiNgramsTableDoc
+
+ , NgramsStatePatch
+ , NgramsTablePatch
+
+ , NgramsElement(..)
+ , mkNgramsElement
+ , mergeNgramsElement
+
+ , RootParent(..)
+
+ , MSet
+ , mSetFromList
+ , mSetToList
+
+ , Repo(..)
+ , r_version
+ , r_state
+ , r_history
+ , NgramsRepo
+ , NgramsRepoElement(..)
+ , saveRepo
+ , initRepo
+
+ , RepoEnv(..)
+ , renv_var
+ , renv_lock
+
+ , TabType(..)
+ , ngramsTypeFromTabType
+
+ , HasRepoVar(..)
+ , HasRepoSaver(..)
+ , HasRepo(..)
+ , RepoCmdM
+ , QueryParamR
+ , TODO(..)
+
+ -- Internals
+ , getNgramsTableMap
+ , tableNgramsPull
+ , tableNgramsPut
+
+ , Versioned(..)
+ , currentVersion
+ , listNgramsChangedSince
+ )
where
-import Prelude (round)
+-- import Debug.Trace (trace)
+import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-}, error)
-- import Gargantext.Database.Schema.User (UserId)
-import Data.Functor (($>))
-import Data.Patch.Class (Replace, replace, new)
---import qualified Data.Map.Strict.Patch as PM
+import Data.Patch.Class (Replace, replace, Action(act), Applicable(..),
+ Composable(..), Transformable(..),
+ PairPatch(..), Patched, ConflictResolution,
+ ConflictResolutionReplace, ours)
+import qualified Data.Map.Strict.Patch as PM
import Data.Monoid
+import Data.Ord (Down(..))
+import Data.Foldable
--import Data.Semigroup
import Data.Set (Set)
+import qualified Data.Set as S
+import qualified Data.List as List
+import Data.Maybe (fromMaybe)
+-- import Data.Tuple.Extra (first)
+import qualified Data.Map.Strict as Map
+import Data.Map.Strict (Map)
import qualified Data.Set as Set
-import Data.Maybe (isJust)
-import Data.Tuple.Extra (first)
--- import qualified Data.Map.Strict as DM
-import Data.Map.Strict (Map, mapKeys, fromListWith)
---import qualified Data.Set as Set
-import Control.Lens (makeLenses, Prism', prism', (^..), (.~), (#), to, withIndex, folded, ifolded)
-import Control.Monad (guard)
-import Control.Monad.Error.Class (MonadError, throwError)
-import Data.Aeson
+import Control.Category ((>>>))
+import Control.Concurrent
+import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~), mapped)
+import Control.Monad.Error.Class (MonadError)
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Aeson hiding ((.=))
import Data.Aeson.TH (deriveJSON)
import Data.Either(Either(Left))
-import Data.Map (lookup)
+-- import Data.Map (lookup)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Swagger hiding (version, patch)
-import Data.Text (Text)
+import Data.Text (Text, isInfixOf, count)
+import Data.Validity
+import Formatting (hprint, int, (%))
+import Formatting.Clock (timeSpecs)
import GHC.Generics (Generic)
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+-- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
+import Gargantext.Database.Config (userMaster)
+import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
+import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Database.Types.Node (NodeType(..))
-import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
-import Gargantext.Database.Schema.Ngrams (NgramsType, NgramsTypeId, ngramsTypeId, NgramsTableData(..))
+import Gargantext.Database.Utils (fromField', HasConnection)
+import Gargantext.Database.Node.Select
+import Gargantext.Database.Ngrams
+--import Gargantext.Database.Lists (listsWith)
+import Gargantext.Database.Schema.Node (HasNodeError)
+import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import qualified Gargantext.Database.Schema.Ngrams as Ngrams
-import Gargantext.Database.Schema.NodeNgram
-import Gargantext.Database.Utils (Cmd)
+-- import Gargantext.Database.Schema.NodeNgram hiding (Action)
import Gargantext.Prelude
-import Gargantext.Core.Types (ListType(..), ListTypeId, ListId, CorpusId, Limit, Offset, listTypeId)
-import Prelude (Enum, Bounded, minBound, maxBound)
+-- import Gargantext.Core.Types (ListTypeId, listTypeId)
+import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, assertValid)
import Servant hiding (Patch)
+import System.Clock (getTime, TimeSpec, Clock(..))
+import System.FileLock (FileLock)
+import System.IO (stderr)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+data TODO = TODO
+ deriving (Generic)
+
+instance ToSchema TODO where
+instance ToParamSchema TODO where
+
------------------------------------------------------------------------
--data FacetFormat = Table | Chart
-data TabType = Docs | Terms | Sources | Authors | Institutes | Trash
+data TabType = Docs | Trash | MoreFav | MoreTrash
+ | Terms | Sources | Authors | Institutes
| Contacts
- deriving (Generic, Enum, Bounded)
+ deriving (Generic, Enum, Bounded, Show)
instance FromHttpApiData TabType
where
parseUrlPiece "Docs" = pure Docs
+ parseUrlPiece "Trash" = pure Trash
+ parseUrlPiece "MoreFav" = pure MoreFav
+ parseUrlPiece "MoreTrash" = pure MoreTrash
+
parseUrlPiece "Terms" = pure Terms
parseUrlPiece "Sources" = pure Sources
parseUrlPiece "Institutes" = pure Institutes
parseUrlPiece "Authors" = pure Authors
- parseUrlPiece "Trash" = pure Trash
parseUrlPiece "Contacts" = pure Contacts
where
arbitrary = elements [minBound .. maxBound]
+newtype MSet a = MSet (Map a ())
+ deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
+
+instance ToJSON a => ToJSON (MSet a) where
+ toJSON (MSet m) = toJSON (Map.keys m)
+ toEncoding (MSet m) = toEncoding (Map.keys m)
+
+mSetFromSet :: Set a -> MSet a
+mSetFromSet = MSet . Map.fromSet (const ())
+
+mSetFromList :: Ord a => [a] -> MSet a
+mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
+
+-- mSetToSet :: Ord a => MSet a -> Set a
+-- mSetToSet (MSet a) = Set.fromList ( Map.keys a)
+mSetToSet :: Ord a => MSet a -> Set a
+mSetToSet = Set.fromList . mSetToList
+
+mSetToList :: MSet a -> [a]
+mSetToList (MSet a) = Map.keys a
+
+instance Foldable MSet where
+ foldMap f (MSet m) = Map.foldMapWithKey (\k _ -> f k) m
+
+instance (Ord a, FromJSON a) => FromJSON (MSet a) where
+ parseJSON = fmap mSetFromList . parseJSON
+
+instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
+ -- TODO
+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
+
------------------------------------------------------------------------
type NgramsTerm = Text
+data RootParent = RootParent
+ { _rp_root :: NgramsTerm
+ , _rp_parent :: NgramsTerm
+ }
+ deriving (Ord, Eq, Show, Generic)
+
+deriveJSON (unPrefix "_rp_") ''RootParent
+makeLenses ''RootParent
+
+data NgramsRepoElement = NgramsRepoElement
+ { _nre_size :: Int
+ , _nre_list :: ListType
+--, _nre_root_parent :: Maybe RootParent
+ , _nre_root :: Maybe NgramsTerm
+ , _nre_parent :: Maybe NgramsTerm
+ , _nre_children :: MSet NgramsTerm
+ }
+ deriving (Ord, Eq, Show, Generic)
+
+deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
+makeLenses ''NgramsRepoElement
+
data NgramsElement =
NgramsElement { _ne_ngrams :: NgramsTerm
+ , _ne_size :: Int
, _ne_list :: ListType
, _ne_occurrences :: Int
+ , _ne_root :: Maybe NgramsTerm
, _ne_parent :: Maybe NgramsTerm
- , _ne_children :: Set NgramsTerm
+ , _ne_children :: MSet NgramsTerm
}
deriving (Ord, Eq, Show, Generic)
deriveJSON (unPrefix "_ne_") ''NgramsElement
makeLenses ''NgramsElement
-instance ToSchema NgramsElement
+mkNgramsElement :: NgramsTerm -> ListType -> Maybe RootParent -> MSet NgramsTerm -> NgramsElement
+mkNgramsElement ngrams list rp children =
+ NgramsElement ngrams size list 1 (_rp_root <$> rp) (_rp_parent <$> rp) children
+ where
+ -- TODO review
+ size = 1 + count " " ngrams
+
+newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
+newNgramsElement mayList ngrams = mkNgramsElement ngrams (fromMaybe GraphTerm mayList) Nothing mempty
+
+instance ToSchema NgramsElement where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
instance Arbitrary NgramsElement where
- arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
+ arbitrary = elements [newNgramsElement Nothing "sport"]
+
+ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
+ngramsElementToRepo
+ (NgramsElement { _ne_size = s
+ , _ne_list = l
+ , _ne_root = r
+ , _ne_parent = p
+ , _ne_children = c
+ }) =
+ NgramsRepoElement
+ { _nre_size = s
+ , _nre_list = l
+ , _nre_parent = p
+ , _nre_root = r
+ , _nre_children = c
+ }
+
+ngramsElementFromRepo :: NgramsTerm -> NgramsRepoElement -> NgramsElement
+ngramsElementFromRepo
+ ngrams
+ (NgramsRepoElement
+ { _nre_size = s
+ , _nre_list = l
+ , _nre_parent = p
+ , _nre_root = r
+ , _nre_children = c
+ }) =
+ NgramsElement { _ne_size = s
+ , _ne_list = l
+ , _ne_root = r
+ , _ne_parent = p
+ , _ne_children = c
+ , _ne_ngrams = ngrams
+ , _ne_occurrences = panic $ "API.Ngrams._ne_occurrences"
+ {-
+ -- Here we could use 0 if we want to avoid any `panic`.
+ -- It will not happen using getTableNgrams if
+ -- getOccByNgramsOnly provides a count of occurrences for
+ -- all the ngrams given.
+ -}
+ }
------------------------------------------------------------------------
-newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
+newtype NgramsTable = NgramsTable [NgramsElement]
deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
+type ListNgrams = NgramsTable
+
+makePrisms ''NgramsTable
+
+-- | Question: why these repetition of Type in this instance
+-- may you document it please ?
+instance Each NgramsTable NgramsTable NgramsElement NgramsElement where
+ each = _NgramsTable . each
+
+-- TODO discuss
-- | TODO Check N and Weight
+{-
toNgramsElement :: [NgramsTableData] -> [NgramsElement]
toNgramsElement ns = map toNgramsElement' ns
where
lt' = maybe (panic "API.Ngrams: listypeId") identity lt
mapParent :: Map Int Text
- mapParent = fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
+ mapParent = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
mapChildren :: Map Text (Set Text)
- mapChildren = mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
- $ fromListWith (<>)
+ mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
+ $ Map.fromListWith (<>)
$ map (first fromJust)
$ filter (isJust . fst)
$ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
+-}
+mockTable :: NgramsTable
+mockTable = NgramsTable
+ [ mkNgramsElement "animal" GraphTerm Nothing (mSetFromList ["dog", "cat"])
+ , mkNgramsElement "cat" GraphTerm (rp "animal") mempty
+ , mkNgramsElement "cats" StopTerm Nothing mempty
+ , mkNgramsElement "dog" GraphTerm (rp "animal") (mSetFromList ["dogs"])
+ , mkNgramsElement "dogs" StopTerm (rp "dog") mempty
+ , mkNgramsElement "fox" GraphTerm Nothing mempty
+ , mkNgramsElement "object" CandidateTerm Nothing mempty
+ , mkNgramsElement "nothing" StopTerm Nothing mempty
+ , mkNgramsElement "organic" GraphTerm Nothing (mSetFromList ["flower"])
+ , mkNgramsElement "flower" GraphTerm (rp "organic") mempty
+ , mkNgramsElement "moon" CandidateTerm Nothing mempty
+ , mkNgramsElement "sky" StopTerm Nothing mempty
+ ]
+ where
+ rp n = Just $ RootParent n n
instance Arbitrary NgramsTable where
- arbitrary = elements
- [ NgramsTable
- [ NgramsElement "animal" GraphList 1 Nothing (Set.fromList ["dog", "cat"])
- , NgramsElement "cat" GraphList 1 (Just "animal") mempty
- , NgramsElement "cats" StopList 4 Nothing mempty
- , NgramsElement "dog" GraphList 3 (Just "animal")(Set.fromList ["dogs"])
- , NgramsElement "dogs" StopList 4 (Just "dog") mempty
- , NgramsElement "fox" GraphList 1 Nothing mempty
- , NgramsElement "object" CandidateList 2 Nothing mempty
- , NgramsElement "nothing" StopList 4 Nothing mempty
- , NgramsElement "organic" GraphList 3 Nothing (Set.singleton "flower")
- , NgramsElement "flower" GraphList 3 (Just "organic") mempty
- , NgramsElement "moon" CandidateList 1 Nothing mempty
- , NgramsElement "sky" StopList 1 Nothing mempty
- ]
- ]
+ arbitrary = pure mockTable
+
instance ToSchema NgramsTable
+------------------------------------------------------------------------
+type NgramsTableMap = Map NgramsTerm NgramsRepoElement
+
------------------------------------------------------------------------
-- On the Client side:
--data Action = InGroup NgramsId NgramsId
}
deriving (Eq, Ord, Show, Generic)
-instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
- arbitrary = PatchSet <$> arbitrary <*> arbitrary
+makeLenses ''PatchSet
+makePrisms ''PatchSet
instance ToJSON a => ToJSON (PatchSet a) where
toJSON = genericToJSON $ unPrefix "_"
instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
parseJSON = genericParseJSON $ unPrefix "_"
+{-
+instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
+ arbitrary = PatchSet <$> arbitrary <*> arbitrary
+
+type instance Patched (PatchSet a) = Set a
+
+type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
+type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
+
+instance Ord a => Semigroup (PatchSet a) where
+ p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem
+ , _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add
+ } -- TODO Review
+
+instance Ord a => Monoid (PatchSet a) where
+ mempty = PatchSet mempty mempty
+
+instance Ord a => Group (PatchSet a) where
+ invert (PatchSet r a) = PatchSet a r
+
+instance Ord a => Composable (PatchSet a) where
+ composable _ _ = undefined
+
+instance Ord a => Action (PatchSet a) (Set a) where
+ act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
+
+instance Applicable (PatchSet a) (Set a) where
+ applicable _ _ = mempty
+
+instance Ord a => Validity (PatchSet a) where
+ validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
+
+instance Ord a => Transformable (PatchSet a) where
+ transformable = undefined
+
+ conflicts _p _q = undefined
+
+ transformWith conflict p q = undefined conflict p q
+
instance ToSchema a => ToSchema (PatchSet a)
+-}
+
+type AddRem = Replace (Maybe ())
+
+remPatch, addPatch :: AddRem
+remPatch = replace (Just ()) Nothing
+addPatch = replace Nothing (Just ())
+
+isRem :: Replace (Maybe ()) -> Bool
+isRem = (== remPatch)
+
+type PatchMap = PM.PatchMap
+
+newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
+ deriving (Eq, Show, Generic, Validity, Semigroup, Monoid,
+ Transformable, Composable)
+
+type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
+type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
+
+-- TODO this breaks module abstraction
+makePrisms ''PM.PatchMap
+
+makePrisms ''PatchMSet
+
+_PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
+_PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
+ where
+ f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
+ f = Map.partition isRem >>> both %~ Map.keysSet
+
+ g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
+ g (rems, adds) = Map.fromSet (const remPatch) rems
+ <> Map.fromSet (const addPatch) adds
+
+instance Ord a => Action (PatchMSet a) (MSet a) where
+ act (PatchMSet p) (MSet m) = MSet $ act p m
+
+instance Ord a => Applicable (PatchMSet a) (MSet a) where
+ applicable (PatchMSet p) (MSet m) = applicable p m
+
+instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
+ toJSON = toJSON . view _PatchMSetIso
+ toEncoding = toEncoding . view _PatchMSetIso
+
+instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
+ parseJSON = fmap (_PatchMSetIso #) . parseJSON
+
+instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
+ arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
+
+instance ToSchema a => ToSchema (PatchMSet a) where
+ -- TODO
+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
+
+type instance Patched (PatchMSet a) = MSet a
+
+instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
+ arbitrary = uncurry replace <$> arbitrary
+ -- If they happen to be equal then the patch is Keep.
instance ToSchema a => ToSchema (Replace a) where
- declareNamedSchema (_ :: proxy (Replace a)) = do
+ declareNamedSchema (_ :: Proxy (Replace a)) = do
-- TODO Keep constructor is not supported here.
aSchema <- declareSchemaRef (Proxy :: Proxy a)
return $ NamedSchema (Just "Replace") $ mempty
- & type_ .~ SwaggerObject
+ & type_ ?~ SwaggerObject
& properties .~
InsOrdHashMap.fromList
[ ("old", aSchema)
& required .~ [ "old", "new" ]
data NgramsPatch =
- NgramsPatch { _patch_children :: PatchSet NgramsTerm
+ NgramsPatch { _patch_children :: PatchMSet NgramsTerm
, _patch_list :: Replace ListType -- TODO Map UserId ListType
}
- deriving (Ord, Eq, Show, Generic)
+ deriving (Eq, Show, Generic)
+
deriveJSON (unPrefix "_") ''NgramsPatch
makeLenses ''NgramsPatch
--- instance Semigroup NgramsPatch where
-
-instance ToSchema NgramsPatch
+instance ToSchema NgramsPatch where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
instance Arbitrary NgramsPatch where
arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
-newtype NgramsTablePatch =
- NgramsTablePatch { _ntp_ngrams_patches :: Map NgramsTerm NgramsPatch }
- deriving (Ord, Eq, Show, Generic, Arbitrary, ToJSON, FromJSON)
-makeLenses ''NgramsTablePatch
+type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType)
+
+_NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
+_NgramsPatch = iso (\(NgramsPatch c l) -> c :*: l) (\(c :*: l) -> NgramsPatch c l)
+
+instance Semigroup NgramsPatch where
+ p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
+
+instance Monoid NgramsPatch where
+ mempty = _NgramsPatch # mempty
+
+instance Validity NgramsPatch where
+ validate p = p ^. _NgramsPatch . to validate
+
+instance Transformable NgramsPatch where
+ transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
+
+ conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
+
+ transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
+ where
+ (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
+
+type ConflictResolutionNgramsPatch =
+ ( ConflictResolutionPatchMSet NgramsTerm
+ , ConflictResolutionReplace ListType
+ )
+type instance ConflictResolution NgramsPatch =
+ ConflictResolutionNgramsPatch
+
+type PatchedNgramsPatch = (Set NgramsTerm, ListType)
+ -- ~ Patched NgramsPatchIso
+type instance Patched NgramsPatch = PatchedNgramsPatch
+
+instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
+ applicable p Nothing = check (p == mempty) "NgramsPatch should be empty here"
+ applicable p (Just nre) =
+ applicable (p ^. patch_children) (nre ^. nre_children) <>
+ applicable (p ^. patch_list) (nre ^. nre_list)
+
+instance Action NgramsPatch NgramsRepoElement where
+ act p = (nre_children %~ act (p ^. patch_children))
+ . (nre_list %~ act (p ^. patch_list))
+
+instance Action NgramsPatch (Maybe NgramsRepoElement) where
+ act = fmap . act
+
+newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
+ deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
+
+instance FromField NgramsTablePatch
+ where
+ fromField = fromField'
+
+instance FromField (PatchMap NgramsType (PatchMap NodeId NgramsTablePatch))
+ where
+ fromField = fromField'
+
+--instance (Ord k, Action pv (Maybe v)) => Action (PatchMap k pv) (Map k v) where
+--
+type instance ConflictResolution NgramsTablePatch =
+ NgramsTerm -> ConflictResolutionNgramsPatch
+
+type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
+ -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
+type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
+
+makePrisms ''NgramsTablePatch
+instance ToSchema (PatchMap NgramsTerm NgramsPatch)
instance ToSchema NgramsTablePatch
--- TODO: replace by mempty once we have the Monoid instance
-emptyNgramsTablePatch :: NgramsTablePatch
-emptyNgramsTablePatch = NgramsTablePatch mempty
+instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
+ applicable p = applicable (p ^. _NgramsTablePatch)
+
+instance Action NgramsTablePatch (Maybe NgramsTableMap) where
+ act p =
+ fmap (execState (reParentNgramsTablePatch p)) .
+ act (p ^. _NgramsTablePatch)
+
+instance Arbitrary NgramsTablePatch where
+ arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
+
+-- Should it be less than an Lens' to preserve PatchMap's abstraction.
+-- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
+-- ntp_ngrams_patches = _NgramsTablePatch . undefined
+
+type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
+
+reRootChildren :: NgramsTerm -> ReParent NgramsTerm
+reRootChildren root ngram = do
+ nre <- use $ at ngram
+ forOf_ (_Just . nre_children . folded) nre $ \child -> do
+ at child . _Just . nre_root ?= root
+ reRootChildren root child
+
+reParent :: Maybe RootParent -> ReParent NgramsTerm
+reParent rp child = do
+ at child . _Just %= ( (nre_parent .~ (_rp_parent <$> rp))
+ . (nre_root .~ (_rp_root <$> rp))
+ )
+ reRootChildren (fromMaybe child (rp ^? _Just . rp_root)) child
+
+reParentAddRem :: RootParent -> NgramsTerm -> ReParent AddRem
+reParentAddRem rp child p =
+ reParent (if isRem p then Nothing else Just rp) child
+
+reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
+reParentNgramsPatch parent ngramsPatch = do
+ root_of_parent <- use (at parent . _Just . nre_root)
+ let
+ root = fromMaybe parent root_of_parent
+ rp = RootParent { _rp_root = root, _rp_parent = parent }
+ itraverse_ (reParentAddRem rp) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
+ -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
+
+reParentNgramsTablePatch :: ReParent NgramsTablePatch
+reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
+ -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
------------------------------------------------------------------------
------------------------------------------------------------------------
{ _v_version :: Version
, _v_data :: a
}
- deriving (Generic)
+ deriving (Generic, Show)
deriveJSON (unPrefix "_v_") ''Versioned
makeLenses ''Versioned
-instance ToSchema a => ToSchema (Versioned a)
+instance ToSchema a => ToSchema (Versioned a) where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_v_")
instance Arbitrary a => Arbitrary (Versioned a) where
arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
type NgramsIdPatch = Patch NgramsId NgramsPatch
ngramsPatch :: Int -> NgramsPatch
-ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
+ngramsPatch n = NgramsPatch (DM.fromList [(1, StopTerm)]) (Set.fromList [n]) Set.empty
toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
toEdit n p = Edit n p
------------------------------------------------------------------------
------------------------------------------------------------------------
-type TableNgramsApiGet = Summary " Table Ngrams API Get"
- :> QueryParam "ngramsType" TabType
- :> QueryParam "list" ListId
- :> QueryParam "limit" Limit
- :> QueryParam "offset" Offset
- :> Get '[JSON] (Versioned NgramsTable)
-
-type TableNgramsApi = Summary " Table Ngrams API Change"
- :> QueryParam "ngramsType" TabType
- :> QueryParam "list" ListId
- :> ReqBody '[JSON] (Versioned NgramsTablePatch)
- :> Put '[JSON] (Versioned NgramsTablePatch)
-
-data NgramError = UnsupportedVersion
- deriving (Show)
-
-class HasNgramError e where
- _NgramError :: Prism' e NgramError
-
-instance HasNgramError ServantErr where
- _NgramError = prism' make match
- where
- err = err500 { errBody = "NgramError: Unsupported version" }
- make UnsupportedVersion = err
- match e = guard (e == err) $> UnsupportedVersion
-
-ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
-ngramError nne = throwError $ _NgramError # nne
-
+{-
-- TODO: Replace.old is ignored which means that if the current list
--- `GraphList` and that the patch is `Replace CandidateList StopList` then
--- the list is going to be `StopList` while it should keep `GraphList`.
+-- `GraphTerm` and that the patch is `Replace CandidateTerm StopTerm` then
+-- the list is going to be `StopTerm` while it should keep `GraphTerm`.
-- However this should not happen in non conflicting situations.
mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
mkListsUpdate nt patches =
| (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
, child <- patch ^.. patch_children . to addOrRem . folded
]
+-}
-ngramsTypeFromTabType :: Maybe TabType -> NgramsType
-ngramsTypeFromTabType maybeTabType =
+ngramsTypeFromTabType :: TabType -> NgramsType
+ngramsTypeFromTabType tabType =
let lieu = "Garg.API.Ngrams: " :: Text in
- case maybeTabType of
- Nothing -> panic (lieu <> "Indicate the Table")
- Just tab -> case tab of
- Sources -> Ngrams.Sources
- Authors -> Ngrams.Authors
- Institutes -> Ngrams.Institutes
- Terms -> Ngrams.NgramsTerms
- _ -> panic $ lieu <> "No Ngrams for this tab"
+ case tabType of
+ Sources -> Ngrams.Sources
+ Authors -> Ngrams.Authors
+ Institutes -> Ngrams.Institutes
+ Terms -> Ngrams.NgramsTerms
+ _ -> panic $ lieu <> "No Ngrams for this tab"
+ -- TODO: This `panic` would disapear with custom NgramsType.
+
+------------------------------------------------------------------------
+data Repo s p = Repo
+ { _r_version :: Version
+ , _r_state :: s
+ , _r_history :: [p]
+ -- first patch in the list is the most recent
+ }
+ deriving (Generic)
+
+instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
+ parseJSON = genericParseJSON $ unPrefix "_r_"
+
+instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
+ toJSON = genericToJSON $ unPrefix "_r_"
+ toEncoding = genericToEncoding $ unPrefix "_r_"
+
+makeLenses ''Repo
+
+initRepo :: Monoid s => Repo s p
+initRepo = Repo 1 mempty []
+
+type NgramsRepo = Repo NgramsState NgramsStatePatch
+type NgramsState = Map NgramsType (Map NodeId NgramsTableMap)
+type NgramsStatePatch = PatchMap NgramsType (PatchMap NodeId NgramsTablePatch)
+
+initMockRepo :: NgramsRepo
+initMockRepo = Repo 1 s []
+ where
+ s = Map.singleton Ngrams.NgramsTerms
+ $ Map.singleton 47254
+ $ Map.fromList
+ [ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ]
+
+data RepoEnv = RepoEnv
+ { _renv_var :: !(MVar NgramsRepo)
+ , _renv_saver :: !(IO ())
+ , _renv_lock :: !FileLock
+ }
+ deriving (Generic)
+
+makeLenses ''RepoEnv
+
+class HasRepoVar env where
+ repoVar :: Getter env (MVar NgramsRepo)
+
+instance HasRepoVar (MVar NgramsRepo) where
+ repoVar = identity
+class HasRepoSaver env where
+ repoSaver :: Getter env (IO ())
+
+class (HasRepoVar env, HasRepoSaver env) => HasRepo env where
+ repoEnv :: Getter env RepoEnv
+
+instance HasRepo RepoEnv where
+ repoEnv = identity
+
+instance HasRepoVar RepoEnv where
+ repoVar = renv_var
+
+instance HasRepoSaver RepoEnv where
+ repoSaver = renv_saver
+
+type RepoCmdM env err m =
+ ( MonadReader env m
+ , MonadError err m
+ , MonadIO m
+ , HasRepo env
+ )
+------------------------------------------------------------------------
+
+saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env )
+ => m ()
+saveRepo = liftIO =<< view repoSaver
+
+listTypeConflictResolution :: ListType -> ListType -> ListType
+listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
+
+ngramsStatePatchConflictResolution
+ :: NgramsType -> NodeId -> NgramsTerm
+ -> ConflictResolutionNgramsPatch
+ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
+ = (const ours, ours)
+ -- undefined {- TODO think this through -}, listTypeConflictResolution)
+
+-- Current state:
+-- Insertions are not considered as patches,
+-- they do not extend history,
+-- they do not bump version.
+insertNewOnly :: a -> Maybe b -> a
+insertNewOnly m = maybe m (const $ error "insertNewOnly: impossible")
+ -- TODO error handling
+
+something :: Monoid a => Maybe a -> a
+something Nothing = mempty
+something (Just a) = a
+
+{- unused
+-- TODO refactor with putListNgrams
+copyListNgrams :: RepoCmdM env err m
+ => NodeId -> NodeId -> NgramsType
+ -> m ()
+copyListNgrams srcListId dstListId ngramsType = do
+ var <- view repoVar
+ liftIO $ modifyMVar_ var $
+ pure . (r_state . at ngramsType %~ (Just . f . something))
+ saveRepo
+ where
+ f :: Map NodeId NgramsTableMap -> Map NodeId NgramsTableMap
+ f m = m & at dstListId %~ insertNewOnly (m ^. at srcListId)
+
+-- TODO refactor with putListNgrams
+-- The list must be non-empty!
+-- The added ngrams must be non-existent!
+addListNgrams :: RepoCmdM env err m
+ => NodeId -> NgramsType
+ -> [NgramsElement] -> m ()
+addListNgrams listId ngramsType nes = do
+ var <- view repoVar
+ liftIO $ modifyMVar_ var $
+ pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
+ saveRepo
+ where
+ m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
+-}
+
+-- If the given list of ngrams elements contains ngrams already in
+-- the repo, they will be ignored.
+putListNgrams :: RepoCmdM env err m
+ => NodeId -> NgramsType
+ -> [NgramsElement] -> m ()
+putListNgrams _ _ [] = pure ()
+putListNgrams listId ngramsType nes = do
+ -- printDebug "putListNgrams" (length nes)
+ var <- view repoVar
+ liftIO $ modifyMVar_ var $
+ pure . (r_state . at ngramsType %~ (Just . (at listId %~ (Just . (<> m) . something)) . something))
+ saveRepo
+ where
+ m = Map.fromList $ (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) <$> nes
+
+-- TODO-ACCESS check
+tableNgramsPost :: RepoCmdM env err m => TabType -> NodeId -> Maybe ListType -> [NgramsTerm] -> m ()
+tableNgramsPost tabType listId mayList =
+ putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
+
+currentVersion :: RepoCmdM env err m => m Version
+currentVersion = do
+ var <- view repoVar
+ r <- liftIO $ readMVar var
+ pure $ r ^. r_version
+
+tableNgramsPull :: RepoCmdM env err m
+ => ListId -> NgramsType
+ -> Version
+ -> m (Versioned NgramsTablePatch)
+tableNgramsPull listId ngramsType p_version = do
+ var <- view repoVar
+ r <- liftIO $ readMVar var
+
+ let
+ q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
+ q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
+
+ pure (Versioned (r ^. r_version) q_table)
-- Apply the given patch to the DB and returns the patch to be applied on the
--- cilent.
--- TODO:
--- In this perliminary version the OT aspect is missing, therefore the version
--- number is always 1 and the returned patch is always empty.
-tableNgramsPatch :: (HasNgramError err, HasNodeError err)
- => CorpusId -> Maybe TabType -> Maybe ListId
+-- client.
+-- TODO-ACCESS check
+tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
+ => TabType -> ListId
-> Versioned NgramsTablePatch
- -> Cmd err (Versioned NgramsTablePatch)
-tableNgramsPatch corpusId maybeTabType maybeList (Versioned version patch) = do
- when (version /= 1) $ ngramError UnsupportedVersion
- let ngramsType = ngramsTypeFromTabType maybeTabType
- listId <- maybe (defaultList corpusId) pure maybeList
- updateNodeNgrams $ NodeNgramsUpdate
- { _nnu_user_list_id = listId
- , _nnu_lists_update = mkListsUpdate ngramsType patch
- , _nnu_rem_children = mkChildrenGroups _rem ngramsType patch
- , _nnu_add_children = mkChildrenGroups _add ngramsType patch
- }
- pure $ Versioned 1 emptyNgramsTablePatch
+ -> m (Versioned NgramsTablePatch)
+tableNgramsPut tabType listId (Versioned p_version p_table)
+ | p_table == mempty = do
+ let ngramsType = ngramsTypeFromTabType tabType
+ tableNgramsPull listId ngramsType p_version
+
+ | otherwise = do
+ let ngramsType = ngramsTypeFromTabType tabType
+ (p0, p0_validity) = PM.singleton listId p_table
+ (p, p_validity) = PM.singleton ngramsType p0
+
+ assertValid p0_validity
+ assertValid p_validity
+
+ var <- view repoVar
+ vq' <- liftIO $ modifyMVar var $ \r -> do
+ let
+ q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
+ (p', q') = transformWith ngramsStatePatchConflictResolution p q
+ r' = r & r_version +~ 1
+ & r_state %~ act p'
+ & r_history %~ (p' :)
+ q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
+ {-
+ -- Ideally we would like to check these properties. However:
+ -- * They should be checked only to debug the code. The client data
+ -- should be able to trigger these.
+ -- * What kind of error should they throw (we are in IO here)?
+ -- * Should we keep modifyMVar?
+ -- * Should we throw the validation in an Exception, catch it around
+ -- modifyMVar and throw it back as an Error?
+ assertValid $ transformable p q
+ assertValid $ applicable p' (r ^. r_state)
+ -}
+ pure (r', Versioned (r' ^. r_version) q'_table)
+
+ saveRepo
+ pure vq'
+
+mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
+mergeNgramsElement _neOld neNew = neNew
+ {-
+ { _ne_list :: ListType
+ If we merge the parents/children we can potentially create cycles!
+ , _ne_parent :: Maybe NgramsTerm
+ , _ne_children :: MSet NgramsTerm
+ }
+ -}
+
+getNgramsTableMap :: RepoCmdM env err m
+ => NodeId -> NgramsType -> m (Versioned NgramsTableMap)
+getNgramsTableMap nodeId ngramsType = do
+ v <- view repoVar
+ repo <- liftIO $ readMVar v
+ pure $ Versioned (repo ^. r_version)
+ (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
+
+type MinSize = Int
+type MaxSize = Int
-- | TODO Errors management
-- TODO: polymorphic for Annuaire or Corpus or ...
-getTableNgrams :: HasNodeError err
- => CorpusId -> Maybe TabType
- -> Maybe ListId -> Maybe Limit -> Maybe Offset
- -> Cmd err (Versioned NgramsTable)
-getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
- let ngramsType = ngramsTypeFromTabType maybeTabType
- listId <- maybe (defaultList cId) pure maybeListId
+-- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
+-- TODO: should take only one ListId
+
+getTime' :: MonadIO m => m TimeSpec
+getTime' = liftIO $ getTime ProcessCPUTime
+
+getTableNgrams :: forall env err m.
+ (RepoCmdM env err m, HasNodeError err, HasConnection env)
+ => NodeType -> NodeId -> TabType
+ -> ListId -> Limit -> Maybe Offset
+ -> Maybe ListType
+ -> Maybe MinSize -> Maybe MaxSize
+ -> Maybe OrderBy
+ -> (NgramsTerm -> Bool)
+ -> m (Versioned NgramsTable)
+getTableNgrams _nType nId tabType listId limit_ offset
+ listType minSize maxSize orderBy searchQuery = do
+
+ t0 <- getTime'
+ -- lIds <- selectNodesWithUsername NodeList userMaster
let
- defaultLimit = 10 -- TODO
- limit_ = maybe defaultLimit identity mlimit
- offset_ = maybe 0 identity moffset
+ ngramsType = ngramsTypeFromTabType tabType
+ offset' = maybe 0 identity offset
+ listType' = maybe (const True) (==) listType
+ minSize' = maybe (const True) (<=) minSize
+ maxSize' = maybe (const True) (>=) maxSize
+
+ selected_node n = minSize' s
+ && maxSize' s
+ && searchQuery (n ^. ne_ngrams)
+ && listType' (n ^. ne_list)
+ where
+ s = n ^. ne_size
+
+ selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
+
+ ---------------------------------------
+ sortOnOrder Nothing = identity
+ sortOnOrder (Just TermAsc) = List.sortOn $ view ne_ngrams
+ sortOnOrder (Just TermDesc) = List.sortOn $ Down . view ne_ngrams
+ sortOnOrder (Just ScoreAsc) = List.sortOn $ view ne_occurrences
+ sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
+
+ ---------------------------------------
+ selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
+ selectAndPaginate tableMap = roots <> inners
+ where
+ list = tableMap ^.. each
+ rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root") (tableMap ^. at r))
+ (ne ^. ne_root)
+ selected_nodes = list & take limit_
+ . drop offset'
+ . filter selected_node
+ . sortOnOrder orderBy
+ roots = rootOf <$> selected_nodes
+ rootsSet = Set.fromList (_ne_ngrams <$> roots)
+ inners = list & filter (selected_inner rootsSet)
+
+ ---------------------------------------
+ setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
+ setScores False table = pure table
+ setScores True table = do
+ let ngrams_terms = (table ^.. each . ne_ngrams)
+ t1 <- getTime'
+ occurrences <- getOccByNgramsOnlyFast' nId
+ listId
+ ngramsType
+ ngrams_terms
+ t2 <- getTime'
+ liftIO $ hprint stderr
+ ("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
+ (length ngrams_terms) t1 t2
+ {-
+ occurrences <- getOccByNgramsOnlySlow nType nId
+ (lIds <> [listId])
+ ngramsType
+ ngrams_terms
+ -}
+ let
+ setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
+
+ pure $ table & each %~ setOcc
+ ---------------------------------------
+
+ -- lists <- catMaybes <$> listsWith userMaster
+ -- trace (show lists) $
+ -- getNgramsTableMap ({-lists <>-} listIds) ngramsType
+
+ let scoresNeeded = needsScores orderBy
+ tableMap1 <- getNgramsTableMap listId ngramsType
+ t1 <- getTime'
+ tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
+ . Map.mapWithKey ngramsElementFromRepo
+ t2 <- getTime'
+ tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
+ . setScores (not scoresNeeded)
+ . selectAndPaginate
+ t3 <- getTime'
+ liftIO $ hprint stderr
+ ("getTableNgrams total=" % timeSpecs
+ % " map1=" % timeSpecs
+ % " map2=" % timeSpecs
+ % " map3=" % timeSpecs
+ % " sql=" % (if scoresNeeded then "map2" else "map3")
+ % "\n"
+ ) t0 t3 t0 t1 t1 t2 t2 t3
+ pure tableMap3
+
+
+-- APIs
+
+-- TODO: find a better place for the code above, All APIs stay here
+type QueryParamR = QueryParam' '[Required, Strict]
+
+
+data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
+ deriving (Generic, Enum, Bounded, Read, Show)
+
+instance FromHttpApiData OrderBy
+ where
+ parseUrlPiece "TermAsc" = pure TermAsc
+ parseUrlPiece "TermDesc" = pure TermDesc
+ parseUrlPiece "ScoreAsc" = pure ScoreAsc
+ parseUrlPiece "ScoreDesc" = pure ScoreDesc
+ parseUrlPiece _ = Left "Unexpected value of OrderBy"
+
+instance ToParamSchema OrderBy
+instance FromJSON OrderBy
+instance ToJSON OrderBy
+instance ToSchema OrderBy
+instance Arbitrary OrderBy
+ where
+ arbitrary = elements [minBound..maxBound]
+
+needsScores :: Maybe OrderBy -> Bool
+needsScores (Just ScoreAsc) = True
+needsScores (Just ScoreDesc) = True
+needsScores _ = False
+
+type TableNgramsApiGet = Summary " Table Ngrams API Get"
+ :> QueryParamR "ngramsType" TabType
+ :> QueryParamR "list" ListId
+ :> QueryParamR "limit" Limit
+ :> QueryParam "offset" Offset
+ :> QueryParam "listType" ListType
+ :> QueryParam "minTermSize" MinSize
+ :> QueryParam "maxTermSize" MaxSize
+ :> QueryParam "orderBy" OrderBy
+ :> QueryParam "search" Text
+ :> Get '[JSON] (Versioned NgramsTable)
+
+type TableNgramsApiPut = Summary " Table Ngrams API Change"
+ :> QueryParamR "ngramsType" TabType
+ :> QueryParamR "list" ListId
+ :> ReqBody '[JSON] (Versioned NgramsTablePatch)
+ :> Put '[JSON] (Versioned NgramsTablePatch)
+
+type TableNgramsApiPost = Summary " Table Ngrams API Adds new ngrams"
+ :> QueryParamR "ngramsType" TabType
+ :> QueryParamR "list" ListId
+ :> QueryParam "listType" ListType
+ :> ReqBody '[JSON] [NgramsTerm]
+ :> Post '[JSON] ()
+
+type TableNgramsApi = TableNgramsApiGet
+ :<|> TableNgramsApiPut
+ :<|> TableNgramsApiPost
+
+getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
+ => NodeId -> TabType
+ -> ListId -> Limit -> Maybe Offset
+ -> Maybe ListType
+ -> Maybe MinSize -> Maybe MaxSize
+ -> Maybe OrderBy
+ -> Maybe Text -- full text search
+ -> m (Versioned NgramsTable)
+getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
+ getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
+ where
+ searchQuery = maybe (const True) isInfixOf mt
+
+-- | Text search is deactivated for now for ngrams by doc only
+getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
+ => DocId -> TabType
+ -> ListId -> Limit -> Maybe Offset
+ -> Maybe ListType
+ -> Maybe MinSize -> Maybe MaxSize
+ -> Maybe OrderBy
+ -> Maybe Text -- full text search
+ -> m (Versioned NgramsTable)
+getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
+ ns <- selectNodesWithUsername NodeList userMaster
+ let ngramsType = ngramsTypeFromTabType tabType
+ ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
+ let searchQuery = flip S.member (S.fromList ngs)
+ getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
+
+
+
+apiNgramsTableCorpus :: ( RepoCmdM env err m
+ , HasNodeError err
+ , HasInvalidError err
+ , HasConnection env
+ )
+ => NodeId -> ServerT TableNgramsApi m
+apiNgramsTableCorpus cId = getTableNgramsCorpus cId
+ :<|> tableNgramsPut
+ :<|> tableNgramsPost
- ngramsTableDatas <-
- Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
- -- printDebug "ngramsTableDatas" ngramsTableDatas
+apiNgramsTableDoc :: ( RepoCmdM env err m
+ , HasNodeError err
+ , HasInvalidError err
+ , HasConnection env
+ )
+ => DocId -> ServerT TableNgramsApi m
+apiNgramsTableDoc dId = getTableNgramsDoc dId
+ :<|> tableNgramsPut
+ :<|> tableNgramsPost
+ -- > add new ngrams in database (TODO AD)
+ -- > index all the corpus accordingly (TODO AD)
- pure $ Versioned 1 $ NgramsTable (toNgramsElement ngramsTableDatas)
+listNgramsChangedSince :: RepoCmdM env err m => ListId -> NgramsType -> Version -> m (Versioned Bool)
+listNgramsChangedSince listId ngramsType version
+ | version < 0 =
+ Versioned <$> currentVersion <*> pure True
+ | otherwise =
+ tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)