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 FlexibleInstances #-}
  27 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  28 {-# LANGUAGE MultiParamTypeClasses #-}
  29 {-# LANGUAGE RankNTypes        #-}
  30 {-# LANGUAGE TypeFamilies      #-}
  31 {-# OPTIONS -fno-warn-orphans #-}
  32
  33 module Gargantext.API.Ngrams
  34   where
  35
  36 import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-})
  37 -- import Gargantext.Database.Schema.User  (UserId)
  38 import Data.Functor (($>))
  39 import Data.Patch.Class (Replace, replace, Action(act), Applicable(..),
  40                          Composable(..), Transformable(..),
  41                          PairPatch(..), Patched, ConflictResolution,
  42                          ConflictResolutionReplace)
  43 import qualified Data.Map.Strict.Patch as PM
  44 import Data.Monoid
  45 --import Data.Semigroup
  46 import Data.Set (Set)
  47 -- import Data.Maybe (isJust)
  48 -- import Data.Tuple.Extra (first)
  49 import qualified Data.Map.Strict as Map
  50 import Data.Map.Strict (Map)
  51 --import qualified Data.Set as Set
  52 import Control.Concurrent
  53 import Control.Lens (makeLenses, makePrisms, Getter, Prism', prism', Iso', iso, from, (^..), (.~), (#), to, {-withIndex, folded, ifolded,-} view, (^.), (+~), (%~), at, _Just, Each(..), dropping, taking)
  54 import Control.Monad (guard)
  55 import Control.Monad.Error.Class (MonadError, throwError)
  56 import Control.Monad.Reader
  57 import Data.Aeson
  58 import Data.Aeson.TH (deriveJSON)
  59 import Data.Either(Either(Left))
  60 -- import Data.Map (lookup)
  61 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
  62 import Data.Swagger hiding (version, patch)
  63 import Data.Text (Text)
  64 import Data.Validity
  65 import GHC.Generics (Generic)
  66 import Gargantext.Core.Utils.Prefix (unPrefix)
  67 import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
  68 -- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
  69 import Gargantext.Database.Schema.Ngrams (NgramsType)
  70 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
  71 -- import Gargantext.Database.Schema.NodeNgram hiding (Action)
  72 import Gargantext.Database.Utils (CmdM)
  73 import Gargantext.Prelude
  74 -- import Gargantext.Core.Types (ListTypeId, listTypeId)
  75 import Gargantext.Core.Types (ListType(..), ListId, CorpusId, Limit, Offset)
  76 import Servant hiding (Patch)
  77 import Test.QuickCheck (elements)
  78 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  79
  80 ------------------------------------------------------------------------
  81 --data FacetFormat = Table | Chart
  82 data TabType   = Docs     | Terms  | Sources | Authors | Institutes | Trash
  83                | Contacts
  84   deriving (Generic, Enum, Bounded)
  85
  86 instance FromHttpApiData TabType
  87   where
  88     parseUrlPiece "Docs"       = pure Docs
  89     parseUrlPiece "Terms"      = pure Terms
  90     parseUrlPiece "Sources"    = pure Sources
  91     parseUrlPiece "Institutes" = pure Institutes
  92     parseUrlPiece "Authors"    = pure Authors
  93     parseUrlPiece "Trash"      = pure Trash
  94
  95     parseUrlPiece "Contacts"   = pure Contacts
  96
  97     parseUrlPiece _            = Left "Unexpected value of TabType"
  98
  99 instance ToParamSchema   TabType
 100 instance ToJSON    TabType
 101 instance FromJSON  TabType
 102 instance ToSchema  TabType
 103 instance Arbitrary TabType
 104   where
 105     arbitrary = elements [minBound .. maxBound]
 106
 107 newtype MSet a = MSet (Map a ())
 108   deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
 109
 110 instance ToJSON a => ToJSON (MSet a) where
 111   toJSON     (MSet m) = toJSON     (Map.keys m)
 112   toEncoding (MSet m) = toEncoding (Map.keys m)
 113
 114 mSetFromSet :: Set a -> MSet a
 115 mSetFromSet = MSet . Map.fromSet (const ())
 116
 117 mSetFromList :: Ord a => [a] -> MSet a
 118 mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
 119
 120 instance (Ord a, FromJSON a) => FromJSON (MSet a) where
 121   parseJSON = fmap mSetFromList . parseJSON
 122
 123 instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
 124   -- TODO
 125
 126 ------------------------------------------------------------------------
 127 type NgramsTerm = Text
 128
 129 data NgramsElement =
 130      NgramsElement { _ne_ngrams      :: NgramsTerm
 131                    , _ne_list        :: ListType
 132                    , _ne_occurrences :: Int
 133                    , _ne_parent      :: Maybe NgramsTerm
 134                    , _ne_children    :: MSet NgramsTerm
 135                    }
 136       deriving (Ord, Eq, Show, Generic)
 137
 138 deriveJSON (unPrefix "_ne_") ''NgramsElement
 139 makeLenses ''NgramsElement
 140
 141 instance ToSchema NgramsElement
 142 instance Arbitrary NgramsElement where
 143   arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
 144
 145 ------------------------------------------------------------------------
 146 newtype NgramsTable = NgramsTable [NgramsElement]
 147   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 148
 149 makePrisms ''NgramsTable
 150
 151 instance Each NgramsTable NgramsTable NgramsElement NgramsElement where
 152   each = _NgramsTable . each
 153
 154 -- TODO discuss
 155 -- | TODO Check N and Weight
 156 {-
 157 toNgramsElement :: [NgramsTableData] -> [NgramsElement]
 158 toNgramsElement ns = map toNgramsElement' ns
 159     where
 160       toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
 161         where
 162           p' = case p of
 163                  Nothing -> Nothing
 164                  Just x  -> lookup x mapParent
 165           c' = maybe mempty identity $ lookup t mapChildren
 166           lt' = maybe (panic "API.Ngrams: listypeId") identity lt
 167
 168       mapParent :: Map Int Text
 169       mapParent   = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
 170
 171       mapChildren :: Map Text (Set Text)
 172       mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
 173                   $ Map.fromListWith (<>)
 174                   $ map (first fromJust)
 175                   $ filter (isJust . fst)
 176                   $ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
 177 -}
 178
 179 mockTable :: NgramsTable
 180 mockTable = NgramsTable
 181   [ NgramsElement "animal"  GraphList     1  Nothing       (mSetFromList ["dog", "cat"])
 182   , NgramsElement "cat"     GraphList     1 (Just "animal") mempty
 183   , NgramsElement "cats"    StopList      4  Nothing        mempty
 184   , NgramsElement "dog"     GraphList     3 (Just "animal")(mSetFromList ["dogs"])
 185   , NgramsElement "dogs"    StopList      4 (Just "dog")    mempty
 186   , NgramsElement "fox"     GraphList     1  Nothing        mempty
 187   , NgramsElement "object"  CandidateList 2  Nothing        mempty
 188   , NgramsElement "nothing" StopList      4  Nothing        mempty
 189   , NgramsElement "organic" GraphList     3  Nothing        (mSetFromList ["flower"])
 190   , NgramsElement "flower"  GraphList     3 (Just "organic") mempty
 191   , NgramsElement "moon"    CandidateList 1  Nothing         mempty
 192   , NgramsElement "sky"     StopList      1  Nothing         mempty
 193   ]
 194
 195 instance Arbitrary NgramsTable where
 196   arbitrary = pure mockTable
 197
 198 instance ToSchema NgramsTable
 199
 200 ------------------------------------------------------------------------
 201 type NgramsTableMap = Map NgramsTerm NgramsElement
 202
 203 ------------------------------------------------------------------------
 204 -- On the Client side:
 205 --data Action = InGroup     NgramsId NgramsId
 206 --            | OutGroup    NgramsId NgramsId
 207 --            | SetListType NgramsId ListType
 208
 209 data PatchSet a = PatchSet
 210   { _rem :: Set a
 211   , _add :: Set a
 212   }
 213   deriving (Eq, Ord, Show, Generic)
 214
 215 makeLenses ''PatchSet
 216 makePrisms ''PatchSet
 217
 218 instance ToJSON a => ToJSON (PatchSet a) where
 219   toJSON     = genericToJSON     $ unPrefix "_"
 220   toEncoding = genericToEncoding $ unPrefix "_"
 221
 222 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
 223   parseJSON = genericParseJSON $ unPrefix "_"
 224
 225 {-
 226 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 227   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 228
 229 type instance Patched (PatchSet a) = Set a
 230
 231 type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
 232 type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
 233
 234 instance Ord a => Semigroup (PatchSet a) where
 235   p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem
 236                     , _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add
 237                     } -- TODO Review
 238
 239 instance Ord a => Monoid (PatchSet a) where
 240   mempty = PatchSet mempty mempty
 241
 242 instance Ord a => Group (PatchSet a) where
 243   invert (PatchSet r a) = PatchSet a r
 244
 245 instance Ord a => Composable (PatchSet a) where
 246   composable _ _ = undefined
 247
 248 instance Ord a => Action (PatchSet a) (Set a) where
 249   act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
 250
 251 instance Applicable (PatchSet a) (Set a) where
 252   applicable _ _ = mempty
 253
 254 instance Ord a => Validity (PatchSet a) where
 255   validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
 256
 257 instance Ord a => Transformable (PatchSet a) where
 258   transformable = undefined
 259
 260   conflicts _p _q = undefined
 261
 262   transformWith conflict p q = undefined conflict p q
 263
 264 instance ToSchema a => ToSchema (PatchSet a)
 265 -}
 266
 267 type AddRem = Replace (Maybe ())
 268
 269 type PatchMap = PM.PatchMap
 270
 271 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
 272   deriving (Eq, Show, Generic, Validity, Semigroup, Monoid, Transformable, Composable)
 273
 274 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
 275 type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
 276
 277 -- TODO this breaks module abstraction
 278 makePrisms ''PM.PatchMap
 279
 280 makePrisms ''PatchMSet
 281
 282 _PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
 283 _PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
 284   where
 285     remPatch = replace (Just ()) Nothing
 286     addPatch = replace Nothing (Just ())
 287     isRem :: Replace (Maybe ()) -> Bool
 288     isRem = (== remPatch)
 289     f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
 290     f m = (Map.keysSet rems, Map.keysSet adds)
 291       where
 292         (rems, adds) = Map.partition isRem m
 293     g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
 294     g (rems, adds) = Map.fromSet (const remPatch) rems
 295                   <> Map.fromSet (const addPatch) adds
 296
 297 instance Ord a => Action (PatchMSet a) (MSet a) where
 298   act (PatchMSet p) (MSet m) = MSet $ act p m
 299
 300 instance Ord a => Applicable (PatchMSet a) (MSet a) where
 301   applicable (PatchMSet p) (MSet m) = applicable p m
 302
 303 instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
 304   toJSON     = toJSON . view _PatchMSetIso
 305   toEncoding = toEncoding . view _PatchMSetIso
 306
 307 instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
 308   parseJSON = fmap (_PatchMSetIso #) . parseJSON
 309
 310 instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
 311   arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
 312
 313 instance ToSchema a => ToSchema (PatchMSet a) where
 314   -- TODO
 315   declareNamedSchema _ = undefined
 316
 317 type instance Patched (PatchMSet a) = MSet a
 318
 319 instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
 320   arbitrary = uncurry replace <$> arbitrary
 321     -- If they happen to be equal then the patch is Keep.
 322
 323 instance ToSchema a => ToSchema (Replace a) where
 324   declareNamedSchema (_ :: proxy (Replace a)) = do
 325     -- TODO Keep constructor is not supported here.
 326     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 327     return $ NamedSchema (Just "Replace") $ mempty
 328       & type_ .~ SwaggerObject
 329       & properties .~
 330           InsOrdHashMap.fromList
 331           [ ("old", aSchema)
 332           , ("new", aSchema)
 333           ]
 334       & required .~ [ "old", "new" ]
 335
 336 data NgramsPatch =
 337      NgramsPatch { _patch_children :: PatchMSet NgramsTerm
 338                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
 339                  }
 340       deriving (Eq, Show, Generic)
 341
 342 deriveJSON (unPrefix "_") ''NgramsPatch
 343 makeLenses ''NgramsPatch
 344
 345 instance ToSchema  NgramsPatch
 346
 347 instance Arbitrary NgramsPatch where
 348   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 349
 350 type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType)
 351
 352 _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
 353 _NgramsPatch = iso (\(NgramsPatch c l) -> c :*: l) (\(c :*: l) -> NgramsPatch c l)
 354
 355 instance Semigroup NgramsPatch where
 356   p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
 357
 358 instance Monoid NgramsPatch where
 359   mempty = _NgramsPatch # mempty
 360
 361 instance Validity NgramsPatch where
 362   validate p = p ^. _NgramsPatch . to validate
 363
 364 instance Transformable NgramsPatch where
 365   transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 366
 367   conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 368
 369   transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
 370     where
 371       (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 372
 373 type ConflictResolutionNgramsPatch =
 374   ( ConflictResolutionPatchMSet NgramsTerm
 375   , ConflictResolutionReplace ListType
 376   )
 377 type instance ConflictResolution NgramsPatch =
 378   ConflictResolutionNgramsPatch
 379
 380 type PatchedNgramsPatch = (Set NgramsTerm, ListType)
 381   -- ~ Patched NgramsPatchIso
 382 type instance Patched NgramsPatch = PatchedNgramsPatch
 383
 384 instance Applicable NgramsPatch (Maybe NgramsElement) where
 385   applicable p Nothing   = check (p == mempty) "NgramsPatch should be empty here"
 386   applicable p (Just ne) =
 387     -- TODO how to patch _ne_parent ?
 388     applicable (p ^. patch_children) (ne ^. ne_children) <>
 389     applicable (p ^. patch_list)     (ne ^. ne_list)
 390
 391 instance Action NgramsPatch (Maybe NgramsElement) where
 392   act _ Nothing   = Nothing
 393   act p (Just ne) =
 394     -- TODO how to patch _ne_parent ?
 395     ne & ne_children %~ act (p ^. patch_children)
 396        & ne_list     %~ act (p ^. patch_list)
 397        & Just
 398
 399 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
 400   deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
 401
 402 --instance (Ord k, Action pv (Maybe v)) => Action (PatchMap k pv) (Map k v) where
 403 --
 404 type instance ConflictResolution NgramsTablePatch =
 405   NgramsTerm -> ConflictResolutionNgramsPatch
 406
 407 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
 408   -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
 409 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
 410
 411 makePrisms ''NgramsTablePatch
 412 instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
 413 instance ToSchema  NgramsTablePatch
 414
 415 instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
 416   applicable p = applicable (p ^. _NgramsTablePatch)
 417
 418 instance Action NgramsTablePatch (Maybe NgramsTableMap) where
 419   act p = act (p ^. _NgramsTablePatch)
 420               -- (v ^? _Just . _NgramsTable)
 421               -- ^? _Just . from _NgramsTable
 422
 423 instance Arbitrary NgramsTablePatch where
 424   arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
 425
 426 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
 427 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
 428 -- ntp_ngrams_patches = _NgramsTablePatch .  undefined
 429
 430 -- TODO: replace by mempty once we have the Monoid instance
 431 emptyNgramsTablePatch :: NgramsTablePatch
 432 emptyNgramsTablePatch = NgramsTablePatch mempty
 433
 434 ------------------------------------------------------------------------
 435 ------------------------------------------------------------------------
 436 type Version = Int
 437
 438 data Versioned a = Versioned
 439   { _v_version :: Version
 440   , _v_data    :: a
 441   }
 442   deriving (Generic)
 443 deriveJSON (unPrefix "_v_") ''Versioned
 444 makeLenses ''Versioned
 445 instance ToSchema a => ToSchema (Versioned a)
 446 instance Arbitrary a => Arbitrary (Versioned a) where
 447   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 448
 449 {-
 450 -- TODO sequencs of modifications (Patchs)
 451 type NgramsIdPatch = Patch NgramsId NgramsPatch
 452
 453 ngramsPatch :: Int -> NgramsPatch
 454 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 455
 456 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 457 toEdit n p = Edit n p
 458 ngramsIdPatch :: Patch NgramsId NgramsPatch
 459 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 460                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 461                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 462                                        ]
 463
 464 -- applyPatchBack :: Patch -> IO Patch
 465 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 466 -}
 467 ------------------------------------------------------------------------
 468 ------------------------------------------------------------------------
 469 ------------------------------------------------------------------------
 470
 471 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 472                       :> QueryParam "ngramsType"   TabType
 473                       :> QueryParam "list"   ListId
 474                       :> QueryParam "limit"  Limit
 475                       :> QueryParam "offset" Offset
 476                       :> Get    '[JSON] (Versioned NgramsTable)
 477
 478 type TableNgramsApi = Summary " Table Ngrams API Change"
 479                       :> QueryParam "ngramsType"   TabType
 480                       :> QueryParam "list"   ListId
 481                       :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 482                       :> Put     '[JSON] (Versioned NgramsTablePatch)
 483
 484 data NgramError = UnsupportedVersion
 485   deriving (Show)
 486
 487 class HasNgramError e where
 488   _NgramError :: Prism' e NgramError
 489
 490 instance HasNgramError ServantErr where
 491   _NgramError = prism' make match
 492     where
 493       err = err500 { errBody = "NgramError: Unsupported version" }
 494       make UnsupportedVersion = err
 495       match e = guard (e == err) $> UnsupportedVersion
 496
 497 ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
 498 ngramError nne = throwError $ _NgramError # nne
 499
 500 {-
 501 -- TODO: Replace.old is ignored which means that if the current list
 502 -- `GraphList` and that the patch is `Replace CandidateList StopList` then
 503 -- the list is going to be `StopList` while it should keep `GraphList`.
 504 -- However this should not happen in non conflicting situations.
 505 mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
 506 mkListsUpdate nt patches =
 507   [ (ngramsTypeId nt, ng, listTypeId lt)
 508   | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 509   , lt <- patch ^.. patch_list . new
 510   ]
 511
 512 mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm)
 513                  -> NgramsType
 514                  -> NgramsTablePatch
 515                  -> [(NgramsTypeId, NgramsParent, NgramsChild)]
 516 mkChildrenGroups addOrRem nt patches =
 517   [ (ngramsTypeId nt, parent, child)
 518   | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 519   , child <- patch ^.. patch_children . to addOrRem . folded
 520   ]
 521 -}
 522
 523 ngramsTypeFromTabType :: Maybe TabType -> NgramsType
 524 ngramsTypeFromTabType maybeTabType =
 525   let lieu = "Garg.API.Ngrams: " :: Text in
 526     case maybeTabType of
 527           Nothing  -> panic (lieu <> "Indicate the Table")
 528           Just tab -> case tab of
 529               Sources    -> Ngrams.Sources
 530               Authors    -> Ngrams.Authors
 531               Institutes -> Ngrams.Institutes
 532               Terms      -> Ngrams.NgramsTerms
 533               _          -> panic $ lieu <> "No Ngrams for this tab"
 534
 535 ------------------------------------------------------------------------
 536 data Repo s p = Repo
 537   { _r_version :: Version
 538   , _r_state   :: s
 539   , _r_history :: [p]
 540     -- ^ first patch in the list is the most recent
 541   }
 542
 543 makeLenses ''Repo
 544
 545 initRepo :: Monoid s => Repo s p
 546 initRepo = Repo 1 mempty []
 547
 548 type NgramsState      = Map ListId (Map NgramsType NgramsTableMap)
 549 type NgramsStatePatch = PatchMap ListId (PatchMap NgramsType NgramsTablePatch)
 550 type NgramsRepo       = Repo NgramsState NgramsStatePatch
 551
 552 initMockRepo :: NgramsRepo
 553 initMockRepo = Repo 1 s []
 554   where
 555     s = Map.singleton 1
 556       $ Map.singleton Ngrams.NgramsTerms
 557       $ Map.fromList
 558       [ (n ^. ne_ngrams, n) | n <- mockTable ^. _NgramsTable ]
 559
 560 class HasRepoVar env where
 561   repoVar :: Getter env (MVar NgramsRepo)
 562
 563 instance HasRepoVar (MVar NgramsRepo) where
 564   repoVar = identity
 565
 566 type RepoCmdM env err m =
 567   ( CmdM env err m
 568   , HasRepoVar env
 569   , HasNodeError err
 570   )
 571 ------------------------------------------------------------------------
 572
 573 listTypeConflictResolution :: ListType -> ListType -> ListType
 574 listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
 575
 576 ngramsStatePatchConflictResolution
 577   :: ListId -> NgramsType -> NgramsTerm
 578   -> ConflictResolutionNgramsPatch
 579 ngramsStatePatchConflictResolution _listId _ngramsType _ngramsTerm
 580   = (undefined {- TODO think this through -}, listTypeConflictResolution)
 581
 582 class HasInvalidError e where
 583   _InvalidError :: Prism' e Validation
 584
 585 instance HasInvalidError ServantErr where
 586   _InvalidError = undefined {-prism' make match
 587     where
 588       err = err500 { errBody = "InvalidError" }
 589       make _ = err
 590       match e = guard (e == err) $> UnsupportedVersion-}
 591
 592 assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
 593 assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
 594
 595 -- Apply the given patch to the DB and returns the patch to be applied on the
 596 -- cilent.
 597 -- TODO:
 598 -- In this perliminary version the OT aspect is missing, therefore the version
 599 -- number is always 1 and the returned patch is always empty.
 600 tableNgramsPatch :: (HasNgramError err, HasNodeError err, HasInvalidError err,
 601                      RepoCmdM env err m)
 602                  => CorpusId -> Maybe TabType -> Maybe ListId
 603                  -> Versioned NgramsTablePatch
 604                  -> m (Versioned NgramsTablePatch)
 605 tableNgramsPatch corpusId maybeTabType maybeList (Versioned p_version p_table) = do
 606   let ngramsType = ngramsTypeFromTabType maybeTabType
 607   listId <- maybe (defaultList corpusId) pure maybeList
 608   let (p0, p0_validity) = PM.singleton ngramsType p_table
 609   let (p, p_validity) = PM.singleton listId p0
 610
 611   assertValid p0_validity
 612   assertValid p_validity
 613
 614   var <- view repoVar
 615   (p'_applicable, vq') <- liftIO $ modifyMVar var $ \r ->
 616     let
 617       q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 618       (p', q') = transformWith ngramsStatePatchConflictResolution p q
 619       r' = r & r_version +~ 1
 620              & r_state   %~ act p'
 621              & r_history %~ (p' :)
 622       q'_table = q' ^. _PatchMap . at listId . _Just . _PatchMap . at ngramsType . _Just
 623       p'_applicable = applicable p' (r ^. r_state)
 624     in
 625     pure (r', (p'_applicable, Versioned (r' ^. r_version) q'_table))
 626   assertValid p'_applicable
 627   pure vq'
 628
 629   {- DB version
 630   when (version /= 1) $ ngramError UnsupportedVersion
 631   updateNodeNgrams $ NodeNgramsUpdate
 632     { _nnu_user_list_id = listId
 633     , _nnu_lists_update = mkListsUpdate ngramsType patch
 634     , _nnu_rem_children = mkChildrenGroups _rem ngramsType patch
 635     , _nnu_add_children = mkChildrenGroups _add ngramsType patch
 636     }
 637   pure $ Versioned 1 emptyNgramsTablePatch
 638   -}
 639
 640 -- | TODO Errors management
 641 --  TODO: polymorphic for Annuaire or Corpus or ...
 642 getTableNgrams :: RepoCmdM env err m
 643                => CorpusId -> Maybe TabType
 644                -> Maybe ListId -> Maybe Limit -> Maybe Offset
 645                -- -> Maybe MinSize -> Maybe MaxSize
 646                -- -> Maybe ListType
 647                -- -> Maybe Text -- full text search
 648                -> m (Versioned NgramsTable)
 649 getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
 650   let ngramsType = ngramsTypeFromTabType maybeTabType
 651   listId <- maybe (defaultList cId) pure maybeListId
 652
 653   let
 654     defaultLimit = 10 -- TODO
 655     limit_  = maybe defaultLimit identity mlimit
 656     offset_ = maybe 0 identity moffset
 657
 658   v <- view repoVar
 659   repo <- liftIO $ readMVar v
 660
 661   let ngrams = repo ^.. r_state
 662                       . at listId . _Just
 663                       . at ngramsType . _Just
 664                       . taking limit_ (dropping offset_ each)
 665
 666   pure $ Versioned (repo ^. r_version) (NgramsTable ngrams)
 667
 668   {-
 669   ngramsTableDatas <-
 670     Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
 671
 672   -- printDebug "ngramsTableDatas" ngramsTableDatas
 673
 674   pure $ Versioned 1 $ NgramsTable (toNgramsElement ngramsTableDatas)
 675   -}