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(..), itraverse_, (.=), both, mapped)
  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.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
  73 import Gargantext.Database.Schema.Ngrams (NgramsType)
  74 import Gargantext.Database.Utils (fromField')
  75 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
  76 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
  77 -- import Gargantext.Database.Schema.NodeNgram hiding (Action)
  78 import Gargantext.Prelude
  79 -- import Gargantext.Core.Types (ListTypeId, listTypeId)
  80 import Gargantext.Core.Types (ListType(..), NodeId, 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 FromField NgramsTablePatch
 410   where
 411     fromField = fromField'
 412
 413 instance FromField (PatchMap NgramsType (PatchMap NodeId NgramsTablePatch))
 414   where
 415     fromField = fromField'
 416
 417 --instance (Ord k, Action pv (Maybe v)) => Action (PatchMap k pv) (Map k v) where
 418 --
 419 type instance ConflictResolution NgramsTablePatch =
 420   NgramsTerm -> ConflictResolutionNgramsPatch
 421
 422 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
 423   -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
 424 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
 425
 426 makePrisms ''NgramsTablePatch
 427 instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
 428 instance ToSchema  NgramsTablePatch
 429
 430 instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
 431   applicable p = applicable (p ^. _NgramsTablePatch)
 432
 433 instance Action NgramsTablePatch (Maybe NgramsTableMap) where
 434   act p =
 435     fmap (execState (reParentNgramsTablePatch p)) .
 436     act (p ^. _NgramsTablePatch)
 437
 438 instance Arbitrary NgramsTablePatch where
 439   arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
 440
 441 -- Should it be less than an Lens' to preserve PatchMap's abstraction.
 442 -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
 443 -- ntp_ngrams_patches = _NgramsTablePatch .  undefined
 444
 445 type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
 446
 447 reParent :: Maybe NgramsTerm -> ReParent NgramsTerm
 448 reParent parent child = at child . _Just . ne_parent .= parent
 449
 450 reParentAddRem :: NgramsTerm -> NgramsTerm -> ReParent AddRem
 451 reParentAddRem parent child p =
 452   reParent (if isRem p then Nothing else Just parent) child
 453
 454 reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
 455 reParentNgramsPatch parent ngramsPatch =
 456   itraverse_ (reParentAddRem parent) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
 457   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 458
 459 reParentNgramsTablePatch :: ReParent NgramsTablePatch
 460 reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
 461   -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
 462
 463 ------------------------------------------------------------------------
 464 ------------------------------------------------------------------------
 465 type Version = Int
 466
 467 data Versioned a = Versioned
 468   { _v_version :: Version
 469   , _v_data    :: a
 470   }
 471   deriving (Generic)
 472 deriveJSON (unPrefix "_v_") ''Versioned
 473 makeLenses ''Versioned
 474 instance ToSchema a => ToSchema (Versioned a)
 475 instance Arbitrary a => Arbitrary (Versioned a) where
 476   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 477
 478 {-
 479 -- TODO sequencs of modifications (Patchs)
 480 type NgramsIdPatch = Patch NgramsId NgramsPatch
 481
 482 ngramsPatch :: Int -> NgramsPatch
 483 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 484
 485 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 486 toEdit n p = Edit n p
 487 ngramsIdPatch :: Patch NgramsId NgramsPatch
 488 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 489                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 490                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 491                                        ]
 492
 493 -- applyPatchBack :: Patch -> IO Patch
 494 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 495 -}
 496 ------------------------------------------------------------------------
 497 ------------------------------------------------------------------------
 498 ------------------------------------------------------------------------
 499
 500 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 501                       :> QueryParam "ngramsType"   TabType
 502                       :> QueryParams "list"   ListId
 503                       :> QueryParam "limit"  Limit
 504                       :> QueryParam "offset" Offset
 505                       :> Get    '[JSON] (Versioned NgramsTable)
 506
 507 type TableNgramsApi = Summary " Table Ngrams API Change"
 508                       :> QueryParam "ngramsType"   TabType
 509                       :> QueryParam' '[Required, Strict] "list" ListId
 510                       :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 511                       :> Put     '[JSON] (Versioned NgramsTablePatch)
 512
 513 data NgramError = UnsupportedVersion
 514   deriving (Show)
 515
 516 class HasNgramError e where
 517   _NgramError :: Prism' e NgramError
 518
 519 instance HasNgramError ServantErr where
 520   _NgramError = prism' make match
 521     where
 522       err = err500 { errBody = "NgramError: Unsupported version" }
 523       make UnsupportedVersion = err
 524       match e = guard (e == err) $> UnsupportedVersion
 525
 526 ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
 527 ngramError nne = throwError $ _NgramError # nne
 528
 529 {-
 530 -- TODO: Replace.old is ignored which means that if the current list
 531 -- `GraphList` and that the patch is `Replace CandidateList StopList` then
 532 -- the list is going to be `StopList` while it should keep `GraphList`.
 533 -- However this should not happen in non conflicting situations.
 534 mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
 535 mkListsUpdate nt patches =
 536   [ (ngramsTypeId nt, ng, listTypeId lt)
 537   | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 538   , lt <- patch ^.. patch_list . new
 539   ]
 540
 541 mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm)
 542                  -> NgramsType
 543                  -> NgramsTablePatch
 544                  -> [(NgramsTypeId, NgramsParent, NgramsChild)]
 545 mkChildrenGroups addOrRem nt patches =
 546   [ (ngramsTypeId nt, parent, child)
 547   | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 548   , child <- patch ^.. patch_children . to addOrRem . folded
 549   ]
 550 -}
 551
 552 ngramsTypeFromTabType :: Maybe TabType -> NgramsType
 553 ngramsTypeFromTabType maybeTabType =
 554   let lieu = "Garg.API.Ngrams: " :: Text in
 555     case maybeTabType of
 556           Nothing  -> panic (lieu <> "Indicate the Table")
 557           Just tab -> case tab of
 558               Sources    -> Ngrams.Sources
 559               Authors    -> Ngrams.Authors
 560               Institutes -> Ngrams.Institutes
 561               Terms      -> Ngrams.NgramsTerms
 562               _          -> panic $ lieu <> "No Ngrams for this tab"
 563
 564 ------------------------------------------------------------------------
 565 data Repo s p = Repo
 566   { _r_version :: Version
 567   , _r_state   :: s
 568   , _r_history :: [p]
 569     -- ^ first patch in the list is the most recent
 570   }
 571
 572 makeLenses ''Repo
 573
 574 initRepo :: Monoid s => Repo s p
 575 initRepo = Repo 1 mempty []
 576
 577 type NgramsRepo       = Repo NgramsState NgramsStatePatch
 578 type NgramsState      = Map NgramsType (Map NodeId NgramsTableMap)
 579 type NgramsStatePatch = PatchMap NgramsType (PatchMap NodeId NgramsTablePatch)
 580
 581 initMockRepo :: NgramsRepo
 582 initMockRepo = Repo 1 s []
 583   where
 584     s = Map.singleton Ngrams.NgramsTerms
 585       $ Map.singleton 47254
 586       $ Map.fromList
 587       [ (n ^. ne_ngrams, n) | n <- mockTable ^. _NgramsTable ]
 588
 589 class HasRepoVar env where
 590   repoVar :: Getter env (MVar NgramsRepo)
 591
 592 instance HasRepoVar (MVar NgramsRepo) where
 593   repoVar = identity
 594
 595 type RepoCmdM env err m =
 596   ( MonadReader env m
 597   , MonadError err m
 598   , MonadIO m
 599   , HasRepoVar env
 600   )
 601 ------------------------------------------------------------------------
 602
 603 listTypeConflictResolution :: ListType -> ListType -> ListType
 604 listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
 605
 606 ngramsStatePatchConflictResolution
 607   :: NgramsType -> NodeId -> NgramsTerm
 608   -> ConflictResolutionNgramsPatch
 609 ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
 610   = (undefined {- TODO think this through -}, listTypeConflictResolution)
 611
 612 class HasInvalidError e where
 613   _InvalidError :: Prism' e Validation
 614
 615 instance HasInvalidError ServantErr where
 616   _InvalidError = undefined {-prism' make match
 617     where
 618       err = err500 { errBody = "InvalidError" }
 619       make _ = err
 620       match e = guard (e == err) $> UnsupportedVersion-}
 621
 622 assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
 623 assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
 624
 625 -- Current state:
 626 --   Insertions are not considered as patches,
 627 --   they do not extend history,
 628 --   they do not bump version.
 629 insertNewOnly :: a -> Maybe a -> Maybe a
 630 insertNewOnly a = maybe (Just a) (const $ error "insertNewOnly: impossible")
 631   -- TODO error handling
 632
 633 something :: Monoid a => Maybe a -> a
 634 something Nothing  = mempty
 635 something (Just a) = a
 636
 637 insertNewListOfNgramsElements :: RepoCmdM env err m => NodeId -> NgramsType
 638                               -> [NgramsElement] -> m ()
 639 insertNewListOfNgramsElements listId ngramsType nes = do
 640   var <- view repoVar
 641   liftIO $ modifyMVar_ var $
 642     pure . (r_state . at ngramsType %~ (Just . (at listId %~ insertNewOnly m) . something))
 643   where
 644     m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
 645
 646 -- Apply the given patch to the DB and returns the patch to be applied on the
 647 -- client.
 648 -- TODO:
 649 -- In this perliminary version the OT aspect is missing, therefore the version
 650 -- number is always 1 and the returned patch is always empty.
 651 tableNgramsPatch :: (HasNgramError err, HasInvalidError err,
 652                      RepoCmdM env err m)
 653                  => CorpusId -> Maybe TabType -> ListId
 654                  -> Versioned NgramsTablePatch
 655                  -> m (Versioned NgramsTablePatch)
 656 tableNgramsPatch _corpusId maybeTabType listId (Versioned p_version p_table) = do
 657   let ngramsType = ngramsTypeFromTabType maybeTabType
 658   let (p0, p0_validity) = PM.singleton listId p_table
 659   let (p, p_validity) = PM.singleton ngramsType p0
 660
 661   assertValid p0_validity
 662   assertValid p_validity
 663
 664   var <- view repoVar
 665   (p'_applicable, vq') <- liftIO $ modifyMVar var $ \r ->
 666     let
 667       q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
 668       (p', q') = transformWith ngramsStatePatchConflictResolution p q
 669       r' = r & r_version +~ 1
 670              & r_state   %~ act p'
 671              & r_history %~ (p' :)
 672       q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
 673       p'_applicable = applicable p' (r ^. r_state)
 674     in
 675     pure (r', (p'_applicable, Versioned (r' ^. r_version) q'_table))
 676   assertValid p'_applicable
 677   pure vq'
 678
 679   {- DB version
 680   when (version /= 1) $ ngramError UnsupportedVersion
 681   updateNodeNgrams $ NodeNgramsUpdate
 682     { _nnu_user_list_id = listId
 683     , _nnu_lists_update = mkListsUpdate ngramsType patch
 684     , _nnu_rem_children = mkChildrenGroups _rem ngramsType patch
 685     , _nnu_add_children = mkChildrenGroups _add ngramsType patch
 686     }
 687   pure $ Versioned 1 mempty
 688   -}
 689
 690 mergeNgramsElement :: NgramsElement -> NgramsElement -> NgramsElement
 691 mergeNgramsElement _neOld neNew = neNew
 692   {-
 693   { _ne_list        :: ListType
 694   If we merge the parents/children we can potentially create cycles!
 695   , _ne_parent      :: Maybe NgramsTerm
 696   , _ne_children    :: MSet NgramsTerm
 697   }
 698   -}
 699
 700 getTableNgrams' :: RepoCmdM env err m
 701                 => [NodeId] -> NgramsType -> m (Versioned NgramsTable)
 702 getTableNgrams' nodeIds ngramsType = do
 703   v <- view repoVar
 704   repo <- liftIO $ readMVar v
 705
 706   let
 707     ngramsMap = repo ^. r_state . at ngramsType . _Just
 708
 709     ngrams =
 710       Map.unionsWith mergeNgramsElement
 711         [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
 712
 713   pure $ Versioned (repo ^. r_version) (NgramsTable (ngrams ^.. each))
 714
 715
 716 -- | TODO Errors management
 717 --  TODO: polymorphic for Annuaire or Corpus or ...
 718 getTableNgrams :: RepoCmdM env err m
 719                => CorpusId -> Maybe TabType
 720                -> [ListId] -> Maybe Limit -> Maybe Offset
 721                -- -> Maybe MinSize -> Maybe MaxSize
 722                -- -> Maybe ListType
 723                -- -> Maybe Text -- full text search
 724                -> m (Versioned NgramsTable)
 725 getTableNgrams _cId maybeTabType listIds mlimit moffset = do
 726   let ngramsType = ngramsTypeFromTabType maybeTabType
 727
 728   let
 729     defaultLimit = 10 -- TODO
 730     limit_  = maybe defaultLimit identity mlimit
 731     offset_ = maybe 0 identity moffset
 732
 733   getTableNgrams' listIds ngramsType
 734     & mapped . v_data . _NgramsTable %~ (take limit_ . drop offset_)
 735