Functions.purs 23.4 KB
Newer Older
1
module Gargantext.Core.NgramsTable.Functions
2 3
  where

4 5
import Gargantext.Prelude

6
import Control.Monad.State (class MonadState, execState)
7 8 9
import Data.Array (head)
import Data.Array as A
import Data.Either (Either(..))
10
import Data.Foldable (foldl)
11
import Data.FoldableWithIndex (foldlWithIndex, foldrWithIndex)
12
import Data.Lens (use, view, (^?), (^.), (?=), (%~), (%=), (.~))
13
import Data.Lens.At (at)
14
import Data.Lens.Common (_Just)
15 16 17
import Data.Lens.Fold (folded, traverseOf_)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List ((:), List(Nil))
18
import Data.List as L
19 20
import Data.Map (Map)
import Data.Map as Map
21
import Data.Maybe (Maybe(..), fromMaybe, fromMaybe', isJust)
22
import Data.Set (Set)
23
import Data.Set as Set
24
import Data.String as S
25
import Data.String.Common as DSC
26 27
import Data.String.Regex (Regex, regex, replace) as R
import Data.String.Regex.Flags (global, multiline) as R
28
import Data.String.Search.KarpRabin as SSKR
29
import Data.String.Utils as SU
30
import Data.These (These(..))
Nicolas Pouillard's avatar
Nicolas Pouillard committed
31
import Data.Traversable (for, traverse_, traverse)
32
import Data.TraversableWithIndex (traverseWithIndex)
33
import Data.Tuple (Tuple(..))
34 35
import Data.Tuple.Nested ((/\))
import Effect (Effect)
36
import Effect.Aff (Aff, launchAff_)
37
import Effect.Class (liftEffect)
38
import Gargantext.AsyncTasks as GAT
39
import Gargantext.Components.Table as T
40
import Gargantext.Components.Table.Types as T
41
import Gargantext.Config.REST (AffRESTError, RESTError, logRESTError)
42
import Gargantext.Config.Utils (handleRESTError)
43
import Gargantext.Core.NgramsTable.Types
44
import Gargantext.Routes (SessionRoute(..))
45
import Gargantext.Sessions (Session, get, post, put)
46
import Gargantext.Types (AsyncTask, AsyncTaskType(..), AsyncTaskWithType(..), CTabNgramType(..), FrontendError, OrderBy(..), ScoreType(..), TabSubType(..), TabType(..), TermList(..), TermSize(..))
47
import Gargantext.Utils.Either (eitherMap)
48
--import Gargantext.Utils.KarpRabin (indicesOfAny)
James Laver's avatar
James Laver committed
49
import Gargantext.Utils.Reactix as R2
50
import Gargantext.Utils.String as GS
51 52
import Partial (crashWith)
import Partial.Unsafe (unsafePartial)
53 54
import Reactix as R
import Toestand as T
55

James Laver's avatar
James Laver committed
56
here :: R2.Here
57
here = R2.here "Gargantext.Core.NgramsTable.Functions"
58

59 60
toVersioned :: forall a. VersionedWithCount a -> Tuple Count (Versioned a)
toVersioned (VersionedWithCount { count, data: d, version }) = Tuple count $ Versioned { data: d, version }
61 62

------------------------------------------------------------------------
63

64 65
initialPageParams :: Session -> Int -> Array Int -> TabType -> PageParams
initialPageParams session nodeId listIds tabType =
66 67
  { listIds
  , nodeId
68
  , params
69 70
  , tabType
  , termSizeFilter: Nothing
71
  , termListFilter: Just MapTerm
72
  , searchQuery: ""
73
  , scoreType: Occurrences
74
  , session
75
  }
76
  where
77
    params = T.initialParams { orderBy = Just (T.DESC $ T.ColumnName "Score") }
78

79 80 81 82 83 84 85


-- TODO
normNgramInternal :: CTabNgramType -> String -> String
normNgramInternal CTabAuthors    = identity
normNgramInternal CTabSources    = identity
normNgramInternal CTabInstitutes = identity
86 87
normNgramInternal CTabTerms      = {- GS.specialCharNormalize
                                   <<< -} S.toLower
88
                               <<< R.replace wordBoundaryReg " "
89

90 91 92
normNgramWithTrim :: CTabNgramType -> String -> String
normNgramWithTrim nt = DSC.trim <<< normNgramInternal nt

93
normNgram :: CTabNgramType -> String -> NgramsTerm
94
normNgram tabType = NormNgramsTerm <<< normNgramWithTrim tabType
95

96
ngramsRepoElementToNgramsElement :: NgramsTerm -> Set Int -> NgramsRepoElement -> NgramsElement
97
ngramsRepoElementToNgramsElement ngrams occurrences (NgramsRepoElement { children, list, parent, root, size }) =
98
  NgramsElement
99
  { children
100
  , list
101
  , ngrams
Nicolas Pouillard's avatar
Nicolas Pouillard committed
102
  , occurrences
103 104 105
  , parent
  , root
  , size -- TODO should we assert that size(ngrams) == size?
106 107
  }

108 109
-----------------------------------------------------------------------------------

Nicolas Pouillard's avatar
Nicolas Pouillard committed
110 111 112 113 114 115 116 117 118 119
lookupRootList :: NgramsTerm -> NgramsTable -> Maybe TermList
lookupRootList ngram (NgramsTable {ngrams_repo_elements: elts}) =
  case Map.lookup ngram elts of
    Nothing -> Nothing
    Just (NgramsRepoElement {list, root: Nothing}) -> Just list
    Just (NgramsRepoElement {root: Just root}) ->
      case Map.lookup root elts of
        Nothing -> Nothing
        Just (NgramsRepoElement {list}) -> Just list -- assert root == Nothing

120
lookupRootListWithChildren :: NgramsTerm -> NgramsTable -> Record Cache -> Maybe TermList
121
lookupRootListWithChildren ngram table@(NgramsTable {ngrams_repo_elements: elts}) { pm, pats } =
122 123
  case Map.lookup ngram elts of
    Nothing -> -- try to find in children
124
      case Map.lookup ngram pm of
125 126 127 128 129 130 131 132
        Nothing -> Nothing
        Just parent' -> lookupRootList parent' table
    Just (NgramsRepoElement {list, root: Nothing}) -> Just list
    Just (NgramsRepoElement {root: Just root}) ->
      case Map.lookup root elts of
        Nothing -> Nothing
        Just (NgramsRepoElement {list}) -> Just list -- assert root == Nothing

133 134 135
wordBoundaryChars :: String
wordBoundaryChars = "[ .,;:!?'\\{}()]"

136
wordBoundaryReg :: R.Regex
137
wordBoundaryReg = case R.regex ("(" <> wordBoundaryChars <> ")") (R.global <> R.multiline) of
138 139
  Left e  -> unsafePartial $ crashWith e
  Right r -> r
140

141
wordBoundaryReg2 :: R.Regex
142
wordBoundaryReg2 = case R.regex ("(" <> wordBoundaryChars <> ")\\1") (R.global <> R.multiline) of
143 144 145
  Left e  -> unsafePartial $ crashWith e
  Right r -> r

146
type Cache =
147 148 149
  ( contextNgrams :: Set NgramsTerm
  , pm            :: Map NgramsTerm NgramsTerm
  , pats          :: Array NgramsTerm )
150

151 152
computeCache :: NgramsTable -> Set NgramsTerm -> Record Cache
computeCache ngrams contextNgrams = { contextNgrams, pm, pats }
153 154 155 156
  where
    NgramsTable { ngrams_repo_elements } = ngrams
    pm = parentMap ngrams_repo_elements

157 158
    contextRepoElements = Map.filterWithKey (\k _v -> Set.member k contextNgrams) ngrams_repo_elements

159 160
    pats :: Array NgramsTerm
    pats = A.fromFoldable $
161
           foldlWithIndex (\term acc (NgramsRepoElement nre) -> Set.union acc $ Set.insert term nre.children) Set.empty contextRepoElements
162 163 164

    -- pats = A.fromFoldable $
    --        foldrWithIndex (\term (NgramsRepoElement nre) acc -> Set.union acc $ Set.insert term nre.children) Set.empty ngrams_repo_elements
165

166 167
-- TODO: while this function works well with word boundaries,
--       it inserts too many spaces.
168 169
highlightNgrams :: Record Cache -> CTabNgramType -> NgramsTable -> String -> Array HighlightElement
highlightNgrams cache@{ pm, pats } ntype table@(NgramsTable {ngrams_repo_elements: elts}) input0 =
170
    -- trace {pats, input0, input, ixs} \_ ->
171
    A.fromFoldable ((\(s /\ ls)-> undb s /\ ls) <$> unsafePartial (foldl goFold ((input /\ Nil) : Nil) ixs))
172
  where
173
    spR x = " " <> R.replace wordBoundaryReg "$1$1" x <> " "
174
    -- reR = R.replace wordBoundaryReg " "
175
    db = S.replaceAll (S.Pattern " ") (S.Replacement "  ")
176
    sp x = " " <> db x <> " "
177
    undb = R.replace wordBoundaryReg2 "$1"
178
    input = spR input0
179
    -- pats = A.fromFoldable (Map.keys elts)
180 181 182 183 184
    -- pats :: Array NgramsTerm
    -- pats = A.fromFoldable $
    --        foldrWithIndex (\term (NgramsRepoElement nre) acc -> Set.union acc $ Set.insert term nre.childre
                                                                -- n) Set.empty elts
             -- foldlWithIndex (\term acc (NgramsRepoElement nre) -> Set.union acc $ Set.insert term nre.children) Set.empty elts
185 186
    hashStruct = SSKR.hashStruct (sp <<< ngramsTermText <$> pats)
    ixs = SSKR.indicesOfAnyHashStruct hashStruct (normNgramInternal ntype input)
187

188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212
    splitAcc :: Partial => Int -> HighlightAccumulator
             -> Tuple HighlightAccumulator HighlightAccumulator
    splitAcc i = go 0 Nil
      where
      go j pref acc =
        case compare i j of
          LT -> crashWith "highlightNgrams: splitAcc': i < j"
          EQ -> L.reverse pref /\ acc
          GT ->
            case acc of
              Nil -> crashWith "highlightNgrams: splitAcc': acc=Nil" -- pref /\ Nil
              elt@(s /\ ls) : elts ->
                let slen = S.length s in
                case compare i (j + slen) of
                  LT -> let {before: s0, after: s1} = S.splitAt (i - j) s in
                        L.reverse ((s0 /\ ls) : pref) /\ ((s1 /\ ls) : elts)
                  EQ -> L.reverse (elt : pref) /\ elts
                  GT -> go (j + slen) (elt : pref) elts


    extractInputTextMatch :: Int -> Int -> String -> String
    extractInputTextMatch i len input = undb $ S.take len $ S.drop (i + 1) input

    addNgramElt ng ne_list (elt /\ elt_lists) = (elt /\ ((ng /\ ne_list) : elt_lists))

213 214
    -- parentMap' :: Map NgramsTerm NgramsTerm
    -- parentMap' = parentMap elts
215

216 217
    goAcc :: Partial => Int -> HighlightAccumulator -> Tuple NgramsTerm Int -> HighlightAccumulator
    goAcc i acc (pat /\ lpat) =
218
      case lookupRootListWithChildren pat table cache of
219
        Nothing ->
220 221
          -- crashWith $ "highlightNgrams: pattern [" <> show pat <> "] missing from table: " <> show table
          acc
222 223
        Just ne_list ->
          let
224 225 226 227
            (acc0 /\ acc1_2) = splitAcc i acc
            (acc1 /\ acc2) = splitAcc (lpat + 1) acc1_2
            text = extractInputTextMatch i lpat input
            ng = normNgram ntype text
228
          in
229 230
            acc0 <> (addNgramElt ng ne_list <$> acc1) <> acc2

231
    goFold :: Partial => HighlightAccumulator -> Tuple Int (Array Int) -> HighlightAccumulator
232 233 234 235 236
    goFold acc (Tuple i pis) = foldl (goAcc i) acc $
                           --  A.sortWith snd $
                               map (\pat -> pat /\ S.length (db (ngramsTermText pat))) $
                               fromMaybe' (\_ -> crashWith "highlightNgrams: out of bounds pattern") $
                               traverse (A.index pats) pis
237

238 239
--applyNgramsTablePatchToSingleTerm :: NgramsTerm -> NgramsTablePatch -> Set NgramsTerm -> Set NgramsTerm
--applyNgramsTablePatchToSingleTerm ngram patch s =
240
--  applyNgramsTablePatch patch $
241 242 243 244 245 246

patchSetFromMap :: forall a. Ord a => Map a Boolean -> PatchSet a
patchSetFromMap m = PatchSet { rem: Map.keys (Map.filter not m)
                             , add: Map.keys (Map.filter identity m) }
  -- TODO Map.partition would be nice here

247 248


249 250 251
applyNgramsPatch :: NgramsPatch -> Maybe NgramsRepoElement -> Maybe NgramsRepoElement
applyNgramsPatch (NgramsReplace {patch_new}) _ = patch_new
applyNgramsPatch (NgramsPatch p)           m = m # _Just <<< _Newtype %~ applyNgramsPatch' p
252 253


254 255 256 257
traversePatchMapWithIndex :: forall f a b k.
                             Applicative f => Ord k => Eq b => Monoid b =>
                             (k -> a -> f b) -> PatchMap k a -> f (PatchMap k b)
traversePatchMapWithIndex f (PatchMap m) = fromMap <$> traverseWithIndex f m
258

259 260 261
singletonPatchMap :: forall k p. k -> p -> PatchMap k p
singletonPatchMap k p = PatchMap (Map.singleton k p)

262 263 264
isEmptyPatchMap :: forall k p. PatchMap k p -> Boolean
isEmptyPatchMap (PatchMap p) = Map.isEmpty p

265 266
mergeMap :: forall k a b c. Ord k => (k -> These a b -> Maybe c) -> Map k a -> Map k b -> Map k c
mergeMap f m1 m2 = Map.mapMaybeWithKey f (Map.unionWith g (This <$> m1) (That <$> m2))
267
  where
268 269 270 271
    g (This p) (That v) = Both p v
    g x _ = x -- impossible

applyPatchMap :: forall k p v. Ord k => (p -> Maybe v -> Maybe v) -> PatchMap k p -> Map k v -> Map k v
272
{-
273 274 275 276 277
applyPatchMap applyPatchValue (PatchMap pm) m = mergeMap f pm m
  where
    f _ (This pv)   = applyPatchValue pv Nothing
    f _ (That v)    = Just v
    f _ (Both pv v) = applyPatchValue pv (Just v)
278 279 280 281
-}
applyPatchMap applyPatchValue (PatchMap pm) m =
    foldl go m (Map.toUnfoldable pm :: List (Tuple k p))
  where
James Laver's avatar
James Laver committed
282
    go m' (Tuple k pv) = Map.alter (applyPatchValue pv) k m'
283

284
----------------------------------------------------------------------------------
285
isEmptyNgramsTablePatch :: NgramsTablePatch -> Boolean
286
isEmptyNgramsTablePatch (NgramsTablePatch ngramsPatches) = isEmptyPatchMap ngramsPatches
287

288
fromNgramsPatches :: NgramsPatches -> NgramsTablePatch
289
fromNgramsPatches ngramsPatches = NgramsTablePatch ngramsPatches
290

291 292 293 294
findNgramRoot :: NgramsTable -> NgramsTerm -> NgramsTerm
findNgramRoot (NgramsTable m) n =
  fromMaybe n (m.ngrams_repo_elements ^? at n <<< _Just <<< _NgramsRepoElement <<< _root <<< _Just)

295
findNgramTermList :: NgramsTable -> NgramsTerm -> Maybe TermList
296 297 298
findNgramTermList (NgramsTable m) n = m.ngrams_repo_elements ^? at r <<< _Just <<< _NgramsRepoElement <<< _list
  where
    r = findNgramRoot (NgramsTable m) n
299

300 301
singletonNgramsTablePatch :: NgramsTerm -> NgramsPatch -> NgramsTablePatch
singletonNgramsTablePatch n p = fromNgramsPatches $ singletonPatchMap n p
302

303
rootsOf :: NgramsTable -> Set NgramsTerm
Nicolas Pouillard's avatar
Nicolas Pouillard committed
304
rootsOf (NgramsTable m) = Map.keys $ Map.mapMaybe isRoot m.ngrams_repo_elements
305
  where
306
    isRoot (NgramsRepoElement { parent }) = parent
307

308 309 310 311 312 313
reRootMaxDepth :: Int
reRootMaxDepth = 100 -- TODO: this is a hack

reRootChildren :: Int -> NgramsTerm -> ReParent NgramsTerm
reRootChildren 0         _    _     = pure unit -- TODO: this is a hack
reRootChildren max_depth root ngram = do
314
  nre <- use (at ngram)
315 316
  traverseOf_ (_Just <<< _NgramsRepoElement <<< _children <<< folded) (\child -> do
    at child <<< _Just <<< _NgramsRepoElement <<< _root ?= root
317
    reRootChildren (max_depth - 1) root child) nre
318 319 320

reParent :: Maybe RootParent -> ReParent NgramsTerm
reParent mrp child = do
321 322
  at child <<< _Just <<< _NgramsRepoElement %= ((_parent .~ (view _parent <$> mrp)) <<<
                                                (_root   .~ (view _root   <$> mrp)))
323
  reRootChildren reRootMaxDepth (fromMaybe child (mrp ^? _Just <<< _root)) child
324 325 326 327 328 329

-- reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
-- ^ GHC would have accepted this type. Here reParentNgramsPatch checks but
--   not its usage in reParentNgramsTablePatch.
reParentNgramsPatch :: forall m. MonadState NgramsTable m
                    => NgramsTerm -> NgramsPatch -> m Unit
330
reParentNgramsPatch _      (NgramsReplace _) = pure unit -- TODO
331 332 333 334
reParentNgramsPatch parent (NgramsPatch {patch_children: PatchSet {rem, add}}) = do
  -- root_of_parent <- use (at parent <<< _Just <<< _NgramsElement <<< _root)
  -- ^ TODO this does not type checks, we do the following two lines instead:
  s <- use (at parent)
335
  let root_of_parent = s ^? (_Just <<< _NgramsRepoElement <<< _root <<< _Just)
336
  let rp = { root: fromMaybe parent root_of_parent, parent }
337 338 339
  traverse_ (reParent Nothing) rem
  traverse_ (reParent $ Just rp) add

340
reParentNgramsTablePatch :: ReParent NgramsPatches
341
reParentNgramsTablePatch = void <<< traversePatchMapWithIndex reParentNgramsPatch
342

343
{-
344 345 346 347 348 349 350 351 352 353 354 355
newElemsTable :: NewElems -> Map NgramsTerm NgramsElement
newElemsTable = mapWithIndex newElem
  where
    newElem ngrams list =
      NgramsElement
        { ngrams
        , list
        , occurrences: 1
        , parent:      Nothing
        , root:        Nothing
        , children:    mempty
        }
356
-}
357

358
applyNgramsTablePatch :: NgramsTablePatch -> NgramsTable -> NgramsTable
359
applyNgramsTablePatch (NgramsTablePatch ngramsPatches) (NgramsTable m) =
360
  execState (reParentNgramsTablePatch ngramsPatches) $
Nicolas Pouillard's avatar
Nicolas Pouillard committed
361 362
  NgramsTable $ m { ngrams_repo_elements =
                      applyPatchMap applyNgramsPatch ngramsPatches m.ngrams_repo_elements }
363

364
applyNgramsPatches :: forall s. CoreState s -> NgramsTable -> NgramsTable
365 366
applyNgramsPatches {ngramsLocalPatch, ngramsStagePatch, ngramsValidPatch} =
  applyNgramsTablePatch (ngramsLocalPatch <> ngramsStagePatch <> ngramsValidPatch)
367
  -- First the valid patch, then the stage patch, and finally the local patch.
368

369
{-
370 371
postNewNgrams :: forall s. Array NgramsTerm -> Maybe TermList -> CoreParams s -> Aff Unit
postNewNgrams newNgrams mayList {nodeId, listIds, tabType, session} =
372
  when (not (A.null newNgrams)) $ do
373
    (_ :: Array Unit) <- post session p newNgrams
374
    pure unit
375
  where p = PutNgrams tabType (head listIds) mayList (Just nodeId)
376

377 378
postNewElems :: forall s. NewElems -> CoreParams s -> Aff Unit
postNewElems newElems params = void $ traverseWithIndex postNewElem newElems
379
  where
380
    postNewElem ngrams list = postNewNgrams [ngrams] (Just list) params
381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396
-}

newNgramPatch :: TermList -> NgramsPatch
newNgramPatch list =
  NgramsReplace
  { patch_old: Nothing
  , patch_new:
      Just $ NgramsRepoElement
      { size: 1 -- TODO
      , list
      , root:     Nothing
      , parent:   Nothing
      , children: mempty
      -- , occurrences: 0 -- TODO
      }
  }
397

398 399
addNewNgramP :: NgramsTerm -> TermList -> NgramsTablePatch
addNewNgramP ngrams list =
400
  NgramsTablePatch $ singletonPatchMap ngrams (newNgramPatch list)
401

402 403 404 405 406 407 408 409 410 411 412
addNewNgramA :: NgramsTerm -> TermList -> CoreAction
addNewNgramA ngrams list = CommitPatch $ addNewNgramP ngrams list

setTermListP :: NgramsTerm -> Replace TermList -> NgramsTablePatch
setTermListP ngram patch_list = singletonNgramsTablePatch ngram pe
  where
    pe = NgramsPatch { patch_list, patch_children: mempty }

setTermListA :: NgramsTerm -> Replace TermList -> CoreAction
setTermListA ngram termList = CommitPatch $ setTermListP ngram termList

413
putNgramsPatches :: forall s. CoreParams s -> VersionedNgramsPatches -> AffRESTError VersionedNgramsPatches
414
putNgramsPatches { listIds, nodeId, session, tabType } = put session putNgrams
415
  where putNgrams = PutNgrams tabType (head listIds) Nothing (Just nodeId)
416

417 418
syncPatches :: forall p s. CoreParams p -> T.Box (CoreState s) -> (Unit -> Aff Unit) -> Effect Unit
syncPatches props state callback = do
419
  { ngramsLocalPatch: ngramsLocalPatch@(NgramsTablePatch ngramsPatches)
420 421
  , ngramsStagePatch
  , ngramsVersion } <- T.read state
422
  when (isEmptyNgramsTablePatch ngramsStagePatch) $ do
423
    let pt = Versioned { data: ngramsPatches, version: ngramsVersion }
424
    launchAff_ $ do
425 426
      ePatches <- putNgramsPatches props pt
      case ePatches of
427
        Left err -> liftEffect $ logRESTError here "[syncPatches]" err
428 429 430
        Right (Versioned { data: newPatch, version: newVersion }) -> do
          callback unit
          liftEffect $ do
arturo's avatar
arturo committed
431
            here.log2 "[syncPatches] setting state, newVersion" newVersion
432 433 434 435 436 437 438
            T.modify_ (\s ->
              -- I think that sometimes this setState does not fully go through.
              -- This is an issue because the version number does not get updated and the subsequent calls
              -- can mess up the patches.
              s {
                  ngramsLocalPatch = fromNgramsPatches mempty
                , ngramsStagePatch = fromNgramsPatches mempty
439 440
                -- , ngramsValidPatch = fromNgramsPatches mempty
                , ngramsValidPatch = fromNgramsPatches newPatch <> ngramsLocalPatch <> s.ngramsValidPatch
441
                -- First the already valid patch, then the local patch, then the newly received newPatch.
442 443
                , ngramsVersion    = newVersion
                }) state
arturo's avatar
arturo committed
444
            here.log2 "[syncPatches] ngramsVersion" newVersion
445 446 447 448 449 450 451
    pure unit

{-
syncPatchesAsync :: forall p s. CoreParams p -> R.State (CoreState s) -> (Unit -> Aff Unit) -> Effect Unit
syncPatchesAsync props@{ listIds, tabType }
                 ({ ngramsLocalPatch: ngramsLocalPatch@{ ngramsPatches }
                  , ngramsStagePatch
452
                  , ngramsValidPatch
453 454 455 456 457 458 459 460
                  , ngramsVersion
                  } /\ setState) callback = do
  when (isEmptyNgramsTablePatch ngramsStagePatch) $ do
    let patch = Versioned { data: ngramsPatches, version: ngramsVersion }
    launchAff_ $ do
      Versioned { data: newPatch, version: newVersion } <- postNgramsPatchesAsync props patch
      callback unit
      liftEffect $ do
arturo's avatar
arturo committed
461
        here.log2 "[syncPatches] setting state, newVersion" newVersion
462 463 464 465
        setState $ \s ->
          s {
              ngramsLocalPatch = fromNgramsPatches mempty
            , ngramsStagePatch = fromNgramsPatches mempty
466 467
            , ngramsValidPatch = fromNgramsPatches newPatch <> ngramsLocalPatch <> s.ngramsValidPatch
                              -- First the already valid patch, then the local patch, then the newly received newPatch.
468 469
            , ngramsVersion    = newVersion
            }
arturo's avatar
arturo committed
470
        here.log2 "[syncPatches] ngramsVersion" newVersion
471
-}
472

473 474 475
commitPatch :: forall s. NgramsTablePatch -> T.Box (CoreState s) -> Effect Unit
commitPatch tablePatch state = do
  T.modify_ (\s -> s { ngramsLocalPatch = tablePatch <> s.ngramsLocalPatch }) state
476
    -- First we apply the patches we have locally and then the new patch (tablePatch).
477

478
loadNgramsTable :: PageParams -> AffRESTError VersionedNgramsTable
479
loadNgramsTable
480 481 482 483
  { nodeId
  , listIds
  , session
  , tabType }
484
  = get session query
485 486 487 488 489 490 491 492 493 494 495
    where
      query = GetNgramsTableAll { listIds
                                , tabType } (Just nodeId)
  -- where query = GetNgrams { limit
  --                         , offset: Just offset
  --                         , listIds
  --                         , orderBy: convOrderBy <$> orderBy
  --                         , searchQuery
  --                         , tabType
  --                         , termListFilter
  --                         , termSizeFilter } (Just nodeId)
496

497
loadNgramsTableAll :: PageParams -> AffRESTError NgramsListByTabType
498
loadNgramsTableAll { nodeId, listIds, session } = do
499 500 501 502 503 504 505
  let
    cTagNgramTypes =
      [ CTabTerms
      , CTabSources
      , CTabAuthors
      , CTabInstitutes
      ]
506
    query tabType = GetNgramsTableAll { listIds, tabType } (Just nodeId)
507

508
  ret <- Map.fromFoldable <$> for cTagNgramTypes \cTagNgramType -> do
509
    let tabType = TabCorpus $ TabNgramType cTagNgramType
510
    result :: Either RESTError VersionedNgramsTable <- get session $ query tabType
511
    pure $ Tuple tabType result
512

513 514
  pure $ eitherMap ret

515
convOrderBy :: T.OrderByDirection T.ColumnName -> OrderBy
516 517
convOrderBy (T.ASC  (T.ColumnName "Score")) = ScoreAsc
convOrderBy (T.DESC (T.ColumnName "Score")) = ScoreDesc
518 519
convOrderBy (T.ASC  _) = TermAsc
convOrderBy (T.DESC _) = TermDesc
520

521
coreDispatch :: forall p s. CoreParams p -> T.Box State -> CoreDispatch
522 523
coreDispatch path state (Synchronize { afterSync }) =
  syncPatches path state afterSync
524 525 526
coreDispatch _ state (CommitPatch pt) =
  commitPatch pt state
coreDispatch _ state ResetPatches =
527 528
  T.modify_ (_ { ngramsLocalPatch = mempty :: NgramsTablePatch
               , ngramsSelection  = mempty :: Set NgramsTerm
529
               , ngramsValidPatch = mempty :: NgramsTablePatch
530
               }) state
531

532 533 534 535 536 537 538 539 540 541 542
isSingleNgramsTerm :: NgramsTerm -> Boolean
isSingleNgramsTerm nt = isSingleTerm $ ngramsTermText nt
  where
    isSingleTerm :: String -> Boolean
    isSingleTerm s = A.length words == 1
      where
        words = A.filter (not S.null) $ DSC.trim <$> (SU.words s)

filterTermSize :: Maybe TermSize -> NgramsTerm -> Boolean
filterTermSize (Just MonoTerm)  nt = isSingleNgramsTerm nt
filterTermSize (Just MultiTerm) nt = not $ isSingleNgramsTerm nt
543
filterTermSize _                _  = true
544

545 546

------------------------------------------------------------------------
547

548 549 550 551 552 553 554 555

chartsAfterSync :: forall props discard.
  { listIds :: Array Int
  , nodeId  :: Int
  , session :: Session
  , tabType :: TabType
  | props
  }
556
  -> T.Box (Array FrontendError)
557
  -> T.Box GAT.Storage
558 559
  -> discard
  -> Aff Unit
560 561
chartsAfterSync path'@{ nodeId } errors tasks _ = do
  eTask <- postNgramsChartsAsync path'
562
  handleRESTError here errors eTask $ \task -> liftEffect $ do
arturo's avatar
arturo committed
563
    here.log2 "[chartsAfterSync] Synchronize task" task
564
    GAT.insert nodeId task tasks
565

566
postNgramsChartsAsync :: forall s. CoreParams s -> AffRESTError AsyncTaskWithType
567
postNgramsChartsAsync { listIds, nodeId, session, tabType } = do
568
    eTask :: Either RESTError AsyncTask <- post session putNgramsAsync acu
569
    pure $ (\task -> AsyncTaskWithType { task, typ: UpdateNgramsCharts }) <$> eTask
570 571 572 573
  where
    acu = AsyncNgramsChartsUpdate { listId: head listIds
                                  , tabType }
    putNgramsAsync = PostNgramsChartsAsync (Just nodeId)
574 575 576 577 578


tablePatchHasNgrams :: NgramsTablePatch -> NgramsTerm -> Boolean
tablePatchHasNgrams (NgramsTablePatch ngramsPatches) ngrams =
  isJust $ ngramsPatches ^. _PatchMap <<< at ngrams