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