src/Gargantext/API/Ngrams.hs

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