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

James Laver's avatar
James Laver committed
53
here :: R2.Here
54
here = R2.here "Gargantext.Core.NgramsTable.Functions"
55

56 57
toVersioned :: forall a. VersionedWithCount a -> Tuple Count (Versioned a)
toVersioned (VersionedWithCount { count, data: d, version }) = Tuple count $ Versioned { data: d, version }
58 59

------------------------------------------------------------------------
60

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

76 77 78 79 80 81 82 83 84


-- TODO
normNgramInternal :: CTabNgramType -> String -> String
normNgramInternal CTabAuthors    = identity
normNgramInternal CTabSources    = identity
normNgramInternal CTabInstitutes = identity
normNgramInternal CTabTerms      = S.toLower <<< R.replace wordBoundaryReg " "

85 86 87
normNgramWithTrim :: CTabNgramType -> String -> String
normNgramWithTrim nt = DSC.trim <<< normNgramInternal nt

88
normNgram :: CTabNgramType -> String -> NgramsTerm
89
normNgram tabType = NormNgramsTerm <<< normNgramWithTrim tabType
90

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

103 104
-----------------------------------------------------------------------------------

Nicolas Pouillard's avatar
Nicolas Pouillard committed
105 106 107 108 109 110 111 112 113 114
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

115 116 117
wordBoundaryChars :: String
wordBoundaryChars = "[ .,;:!?'\\{}()]"

118
wordBoundaryReg :: R.Regex
119
wordBoundaryReg = case R.regex ("(" <> wordBoundaryChars <> ")") (R.global <> R.multiline) of
120 121
  Left e  -> unsafePartial $ crashWith e
  Right r -> r
122

123
wordBoundaryReg2 :: R.Regex
124
wordBoundaryReg2 = case R.regex ("(" <> wordBoundaryChars <> ")\\1") (R.global <> R.multiline) of
125 126 127
  Left e  -> unsafePartial $ crashWith e
  Right r -> r

128 129
-- TODO: while this function works well with word boundaries,
--       it inserts too many spaces.
130
highlightNgrams :: CTabNgramType -> NgramsTable -> String -> Array HighlightElement
Nicolas Pouillard's avatar
Nicolas Pouillard committed
131
highlightNgrams ntype table@(NgramsTable {ngrams_repo_elements: elts}) input0 =
132
    -- trace {pats, input0, input, ixs} \_ ->
133
    A.fromFoldable ((\(s /\ ls)-> undb s /\ ls) <$> unsafePartial (foldl goFold ((input /\ Nil) : Nil) ixs))
134
  where
135
    spR x = " " <> R.replace wordBoundaryReg "$1$1" x <> " "
136
    -- reR = R.replace wordBoundaryReg " "
137
    db = S.replaceAll (S.Pattern " ") (S.Replacement "  ")
138
    sp x = " " <> db x <> " "
139
    undb = R.replace wordBoundaryReg2 "$1"
140
    input = spR input0
Nicolas Pouillard's avatar
Nicolas Pouillard committed
141
    pats = A.fromFoldable (Map.keys elts)
142 143
    hashStruct = SSKR.hashStruct (sp <<< ngramsTermText <$> pats)
    ixs = SSKR.indicesOfAnyHashStruct hashStruct (normNgramInternal ntype input)
144

145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171
    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))

    goAcc :: Partial => Int -> HighlightAccumulator -> Tuple NgramsTerm Int -> HighlightAccumulator
    goAcc i acc (pat /\ lpat) =
172
      case lookupRootList pat table of
173
        Nothing ->
174 175 176
          crashWith "highlightNgrams: pattern missing from table"
        Just ne_list ->
          let
177 178 179 180
            (acc0 /\ acc1_2) = splitAcc i acc
            (acc1 /\ acc2) = splitAcc (lpat + 1) acc1_2
            text = extractInputTextMatch i lpat input
            ng = normNgram ntype text
181
          in
182 183
            acc0 <> (addNgramElt ng ne_list <$> acc1) <> acc2

184
    goFold :: Partial => HighlightAccumulator -> Tuple Int (Array Int) -> HighlightAccumulator
185 186 187 188 189
    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
190

191 192
--applyNgramsTablePatchToSingleTerm :: NgramsTerm -> NgramsTablePatch -> Set NgramsTerm -> Set NgramsTerm
--applyNgramsTablePatchToSingleTerm ngram patch s =
193
--  applyNgramsTablePatch patch $
194 195 196 197 198 199

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

200 201


202 203 204
applyNgramsPatch :: NgramsPatch -> Maybe NgramsRepoElement -> Maybe NgramsRepoElement
applyNgramsPatch (NgramsReplace {patch_new}) _ = patch_new
applyNgramsPatch (NgramsPatch p)           m = m # _Just <<< _Newtype %~ applyNgramsPatch' p
205 206


207 208 209 210
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
211

212 213 214
singletonPatchMap :: forall k p. k -> p -> PatchMap k p
singletonPatchMap k p = PatchMap (Map.singleton k p)

215 216 217
isEmptyPatchMap :: forall k p. PatchMap k p -> Boolean
isEmptyPatchMap (PatchMap p) = Map.isEmpty p

218 219
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))
220
  where
221 222 223 224
    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
225
{-
226 227 228 229 230
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)
231 232 233 234
-}
applyPatchMap applyPatchValue (PatchMap pm) m =
    foldl go m (Map.toUnfoldable pm :: List (Tuple k p))
  where
James Laver's avatar
James Laver committed
235
    go m' (Tuple k pv) = Map.alter (applyPatchValue pv) k m'
236

237
----------------------------------------------------------------------------------
238
isEmptyNgramsTablePatch :: NgramsTablePatch -> Boolean
239
isEmptyNgramsTablePatch (NgramsTablePatch ngramsPatches) = isEmptyPatchMap ngramsPatches
240

241
fromNgramsPatches :: NgramsPatches -> NgramsTablePatch
242
fromNgramsPatches ngramsPatches = NgramsTablePatch ngramsPatches
243

244 245 246 247
findNgramRoot :: NgramsTable -> NgramsTerm -> NgramsTerm
findNgramRoot (NgramsTable m) n =
  fromMaybe n (m.ngrams_repo_elements ^? at n <<< _Just <<< _NgramsRepoElement <<< _root <<< _Just)

248
findNgramTermList :: NgramsTable -> NgramsTerm -> Maybe TermList
249 250 251
findNgramTermList (NgramsTable m) n = m.ngrams_repo_elements ^? at r <<< _Just <<< _NgramsRepoElement <<< _list
  where
    r = findNgramRoot (NgramsTable m) n
252

253 254
singletonNgramsTablePatch :: NgramsTerm -> NgramsPatch -> NgramsTablePatch
singletonNgramsTablePatch n p = fromNgramsPatches $ singletonPatchMap n p
255

256
rootsOf :: NgramsTable -> Set NgramsTerm
Nicolas Pouillard's avatar
Nicolas Pouillard committed
257
rootsOf (NgramsTable m) = Map.keys $ Map.mapMaybe isRoot m.ngrams_repo_elements
258
  where
259
    isRoot (NgramsRepoElement { parent }) = parent
260

261 262 263 264 265 266
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
267
  nre <- use (at ngram)
268 269
  traverseOf_ (_Just <<< _NgramsRepoElement <<< _children <<< folded) (\child -> do
    at child <<< _Just <<< _NgramsRepoElement <<< _root ?= root
270
    reRootChildren (max_depth - 1) root child) nre
271 272 273

reParent :: Maybe RootParent -> ReParent NgramsTerm
reParent mrp child = do
274 275
  at child <<< _Just <<< _NgramsRepoElement %= ((_parent .~ (view _parent <$> mrp)) <<<
                                                (_root   .~ (view _root   <$> mrp)))
276
  reRootChildren reRootMaxDepth (fromMaybe child (mrp ^? _Just <<< _root)) child
277 278 279 280 281 282

-- 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
283
reParentNgramsPatch _      (NgramsReplace _) = pure unit -- TODO
284 285 286 287
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)
288
  let root_of_parent = s ^? (_Just <<< _NgramsRepoElement <<< _root <<< _Just)
289
  let rp = { root: fromMaybe parent root_of_parent, parent }
290 291 292
  traverse_ (reParent Nothing) rem
  traverse_ (reParent $ Just rp) add

293
reParentNgramsTablePatch :: ReParent NgramsPatches
294
reParentNgramsTablePatch = void <<< traversePatchMapWithIndex reParentNgramsPatch
295

296
{-
297 298 299 300 301 302 303 304 305 306 307 308
newElemsTable :: NewElems -> Map NgramsTerm NgramsElement
newElemsTable = mapWithIndex newElem
  where
    newElem ngrams list =
      NgramsElement
        { ngrams
        , list
        , occurrences: 1
        , parent:      Nothing
        , root:        Nothing
        , children:    mempty
        }
309
-}
310

311
applyNgramsTablePatch :: NgramsTablePatch -> NgramsTable -> NgramsTable
312
applyNgramsTablePatch (NgramsTablePatch ngramsPatches) (NgramsTable m) =
313
  execState (reParentNgramsTablePatch ngramsPatches) $
Nicolas Pouillard's avatar
Nicolas Pouillard committed
314 315
  NgramsTable $ m { ngrams_repo_elements =
                      applyPatchMap applyNgramsPatch ngramsPatches m.ngrams_repo_elements }
316

317 318 319
applyNgramsPatches :: forall s. CoreState s -> NgramsTable -> NgramsTable
applyNgramsPatches {ngramsLocalPatch, ngramsStagePatch, ngramsValidPatch} =
  applyNgramsTablePatch (ngramsLocalPatch <> ngramsStagePatch <> ngramsValidPatch)
320
  -- First the valid patch, then the stage patch, and finally the local patch.
321

322
{-
323 324
postNewNgrams :: forall s. Array NgramsTerm -> Maybe TermList -> CoreParams s -> Aff Unit
postNewNgrams newNgrams mayList {nodeId, listIds, tabType, session} =
325
  when (not (A.null newNgrams)) $ do
326
    (_ :: Array Unit) <- post session p newNgrams
327
    pure unit
328
  where p = PutNgrams tabType (head listIds) mayList (Just nodeId)
329

330 331
postNewElems :: forall s. NewElems -> CoreParams s -> Aff Unit
postNewElems newElems params = void $ traverseWithIndex postNewElem newElems
332
  where
333
    postNewElem ngrams list = postNewNgrams [ngrams] (Just list) params
334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349
-}

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
      }
  }
350

351 352
addNewNgramP :: NgramsTerm -> TermList -> NgramsTablePatch
addNewNgramP ngrams list =
353
  NgramsTablePatch $ singletonPatchMap ngrams (newNgramPatch list)
354

355 356 357 358 359 360 361 362 363 364 365
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

366
putNgramsPatches :: forall s. CoreParams s -> VersionedNgramsPatches -> AffRESTError VersionedNgramsPatches
367
putNgramsPatches { listIds, nodeId, session, tabType } = put session putNgrams
368
  where putNgrams = PutNgrams tabType (head listIds) Nothing (Just nodeId)
369

370 371
syncPatches :: forall p s. CoreParams p -> T.Box (CoreState s) -> (Unit -> Aff Unit) -> Effect Unit
syncPatches props state callback = do
372
  { ngramsLocalPatch: ngramsLocalPatch@(NgramsTablePatch ngramsPatches)
373 374
  , ngramsStagePatch
  , ngramsVersion } <- T.read state
375
  when (isEmptyNgramsTablePatch ngramsStagePatch) $ do
376
    let pt = Versioned { data: ngramsPatches, version: ngramsVersion }
377
    launchAff_ $ do
378 379
      ePatches <- putNgramsPatches props pt
      case ePatches of
380
        Left err -> liftEffect $ logRESTError here "[syncPatches]" err
381 382 383
        Right (Versioned { data: newPatch, version: newVersion }) -> do
          callback unit
          liftEffect $ do
arturo's avatar
arturo committed
384
            here.log2 "[syncPatches] setting state, newVersion" newVersion
385 386 387 388 389 390 391 392
            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
                , ngramsValidPatch = fromNgramsPatches newPatch <> ngramsLocalPatch <> s.ngramsValidPatch
393
                              -- First the already valid patch, then the local patch, then the newly received newPatch.
394 395
                , ngramsVersion    = newVersion
                }) state
arturo's avatar
arturo committed
396
            here.log2 "[syncPatches] ngramsVersion" newVersion
397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412
    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
                  , ngramsValidPatch
                  , 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
413
        here.log2 "[syncPatches] setting state, newVersion" newVersion
414 415 416 417 418 419 420 421
        setState $ \s ->
          s {
              ngramsLocalPatch = fromNgramsPatches mempty
            , ngramsStagePatch = fromNgramsPatches mempty
            , ngramsValidPatch = fromNgramsPatches newPatch <> ngramsLocalPatch <> s.ngramsValidPatch
                              -- First the already valid patch, then the local patch, then the newly received newPatch.
            , ngramsVersion    = newVersion
            }
arturo's avatar
arturo committed
422
        here.log2 "[syncPatches] ngramsVersion" newVersion
423
-}
424

425 426 427
commitPatch :: forall s. NgramsTablePatch -> T.Box (CoreState s) -> Effect Unit
commitPatch tablePatch state = do
  T.modify_ (\s -> s { ngramsLocalPatch = tablePatch <> s.ngramsLocalPatch }) state
428
    -- First we apply the patches we have locally and then the new patch (tablePatch).
429

430
loadNgramsTable :: PageParams -> AffRESTError VersionedNgramsTable
431
loadNgramsTable
432 433 434 435
  { nodeId
  , listIds
  , session
  , tabType }
436
  = get session query
437 438 439 440 441 442 443 444 445 446 447
    where
      query = GetNgramsTableAll { listIds
                                , tabType } (Just nodeId)
  -- where query = GetNgrams { limit
  --                         , offset: Just offset
  --                         , listIds
  --                         , orderBy: convOrderBy <$> orderBy
  --                         , searchQuery
  --                         , tabType
  --                         , termListFilter
  --                         , termSizeFilter } (Just nodeId)
448

449
loadNgramsTableAll :: PageParams -> AffRESTError NgramsListByTabType
450
loadNgramsTableAll { nodeId, listIds, session } = do
451 452 453 454 455 456 457
  let
    cTagNgramTypes =
      [ CTabTerms
      , CTabSources
      , CTabAuthors
      , CTabInstitutes
      ]
458
    query tabType = GetNgramsTableAll { listIds, tabType } (Just nodeId)
459

460
  ret <- Map.fromFoldable <$> for cTagNgramTypes \cTagNgramType -> do
461
    let tabType = TabCorpus $ TabNgramType cTagNgramType
462
    result :: Either RESTError VersionedNgramsTable <- get session $ query tabType
463
    pure $ Tuple tabType result
464

465 466
  pure $ eitherMap ret

467
convOrderBy :: T.OrderByDirection T.ColumnName -> OrderBy
468 469
convOrderBy (T.ASC  (T.ColumnName "Score")) = ScoreAsc
convOrderBy (T.DESC (T.ColumnName "Score")) = ScoreDesc
470 471
convOrderBy (T.ASC  _) = TermAsc
convOrderBy (T.DESC _) = TermDesc
472

473
coreDispatch :: forall p s. CoreParams p -> T.Box (CoreState s) -> CoreDispatch
474 475
coreDispatch path state (Synchronize { afterSync }) =
  syncPatches path state afterSync
476 477 478
coreDispatch _ state (CommitPatch pt) =
  commitPatch pt state
coreDispatch _ state ResetPatches =
479
  T.modify_ (_ { ngramsLocalPatch = mempty :: NgramsTablePatch }) state
480

481 482 483 484 485 486 487 488 489 490 491
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
492
filterTermSize _                _  = true
493

494 495

------------------------------------------------------------------------
496

497 498 499 500 501 502 503 504

chartsAfterSync :: forall props discard.
  { listIds :: Array Int
  , nodeId  :: Int
  , session :: Session
  , tabType :: TabType
  | props
  }
505
  -> T.Box (Array FrontendError)
506
  -> T.Box GAT.Storage
507 508
  -> discard
  -> Aff Unit
509 510 511
chartsAfterSync path'@{ nodeId } errors tasks _ = do
  eTask <- postNgramsChartsAsync path'
  handleRESTError errors eTask $ \task -> liftEffect $ do
arturo's avatar
arturo committed
512
    here.log2 "[chartsAfterSync] Synchronize task" task
513
    GAT.insert nodeId task tasks
514

515
postNgramsChartsAsync :: forall s. CoreParams s -> AffRESTError AsyncTaskWithType
516
postNgramsChartsAsync { listIds, nodeId, session, tabType } = do
517
    eTask :: Either RESTError AsyncTask <- post session putNgramsAsync acu
518
    pure $ (\task -> AsyncTaskWithType { task, typ: UpdateNgramsCharts }) <$> eTask
519 520 521 522
  where
    acu = AsyncNgramsChartsUpdate { listId: head listIds
                                  , tabType }
    putNgramsAsync = PostNgramsChartsAsync (Just nodeId)
523 524 525 526 527


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