Core.purs 40.4 KB
Newer Older
1 2
module Gargantext.Components.NgramsTable.Core
  ( PageParams
3
  , CoreParams
4 5
  , NgramsElement(..)
  , _NgramsElement
6 7 8
  , NgramsRepoElement(..)
  , _NgramsRepoElement
  , ngramsRepoElementToNgramsElement
9 10 11
  , NgramsPatch(..)
  , NgramsTable(..)
  , NgramsTablePatch
12 13
  , NewElems
  , NgramsPatches
14 15
  , _NgramsTable
  , NgramsTerm
16
  , normNgram
17
  , ngramsTermText
18
  , findNgramRoot
19
  , findNgramTermList
20 21
  , Version
  , Versioned(..)
22
  , VersionedNgramsPatches
23
  , AsyncNgramsChartsUpdate
24 25 26 27 28
  , VersionedNgramsTable
  , CoreState
  , highlightNgrams
  , initialPageParams
  , loadNgramsTable
29
  , loadNgramsTableAll
30 31 32 33 34
  , convOrderBy
  , Replace(..) -- Ideally we should keep the constructors hidden
  , replace
  , PatchSet(..)
  , PatchMap(..)
35
  , _PatchMap
36 37
  , patchSetFromMap
  , applyPatchSet
38
--, applyNgramsTablePatch -- re-export only if we have a good reason not to use applyNgramsPatches
39
  , applyNgramsPatches
40
  , rootsOf
41 42 43
  , singletonPatchMap
  , fromNgramsPatches
  , singletonNgramsTablePatch
44
  , isEmptyNgramsTablePatch
45 46 47 48 49 50
  , _list
  , _occurrences
  , _children
  , _ngrams
  , _parent
  , _root
Nicolas Pouillard's avatar
Nicolas Pouillard committed
51 52
  , _ngrams_repo_elements
  , _ngrams_scores
53
  , commitPatch
54
  , putNgramsPatches
55
  , postNgramsChartsAsync
56
  , syncPatches
57 58 59 60 61 62
  , addNewNgramP
  , addNewNgramA
  , setTermListP
  , setTermListA
  , CoreAction(..)
  , CoreDispatch
63 64
  , Action(..)
  , Dispatch
65
  , coreDispatch
66 67
  , isSingleNgramsTerm
  , filterTermSize
68 69 70
  , SyncResetButtonsProps
  , syncResetButtons
  , syncResetButtonsCpt
71 72 73
  )
  where

74
import Prelude
75 76

import Control.Monad.State (class MonadState, execState)
77
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson, jsonEmptyObject, (.:), (.:!), (.:?), (:=), (:=?), (~>), (~>?))
78
import Data.Argonaut.Decode.Error (JsonDecodeError(..))
79 80
import Data.Array (head)
import Data.Array as A
81
import Data.Bifunctor (lmap)
82 83 84
import Data.Either (Either(..))
import Data.Foldable (class Foldable, foldMap, foldl, foldr)
import Data.FoldableWithIndex (class FoldableWithIndex, foldMapWithIndex, foldlWithIndex, foldrWithIndex)
85
--import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
86 87 88 89
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Ord (genericCompare)
import Data.Generic.Rep.Show (genericShow)
90
import Data.Lens (Iso', Lens', use, view, (%=), (%~), (.~), (?=), (^?), (^.))
91
import Data.Lens.At (class At, at)
92
import Data.Lens.Common (_Just)
93
import Data.Lens.Fold (folded, traverseOf_)
94
import Data.Lens.Index (class Index, ix)
95
import Data.Lens.Iso.Newtype (_Newtype)
96
import Data.Lens.Record (prop)
97 98 99
import Data.List ((:), List(Nil))
import Data.Map (Map)
import Data.Map as Map
100
import Data.Maybe (Maybe(..), fromMaybe, isJust)
Nicolas Pouillard's avatar
Nicolas Pouillard committed
101
import Data.Monoid.Additive (Additive(..))
102
import Data.Newtype (class Newtype)
103 104 105
import Data.Set (Set)
import Data.Set as Set
import Data.String as S
106
import Data.String.Common as DSC
107 108
import Data.String.Regex (Regex, regex, replace) as R
import Data.String.Regex.Flags (global, multiline) as R
109
import Data.String.Utils as SU
110
import Data.Symbol (SProxy(..))
111 112 113
import Data.These (These(..))
import Data.Traversable (for, traverse_)
import Data.TraversableWithIndex (traverseWithIndex)
114
import Data.Tuple (Tuple(..), snd)
115
import Data.Tuple.Nested ((/\))
116
import DOM.Simple.Console (log2)
117 118 119
import Effect.Aff (Aff, launchAff_)
import Effect (Effect)
import Effect.Class (liftEffect)
120
import Effect.Exception.Unsafe (unsafeThrow)
121
import Foreign.Object as FO
122 123 124
import FFI.Simple.Functions (delay)
import Reactix as R
import Reactix.DOM.HTML as H
125 126 127
import Partial (crashWith)
import Partial.Unsafe (unsafePartial)

128
import Gargantext.AsyncTasks as GAT
129
import Gargantext.Components.Table as T
130
import Gargantext.Prelude
131
import Gargantext.Routes (SessionRoute(..))
132 133
import Gargantext.Sessions (Session, get, post, put)
import Gargantext.Types (AsyncTaskType(..), AsyncTaskWithType(..), CTabNgramType(..), ListId, OrderBy(..), ScoreType(..), TabSubType(..), TabType(..), TermList(..), TermSize(..))
134
import Gargantext.Utils.KarpRabin (indicesOfAny)
135

136 137 138
thisModule :: String
thisModule = "Gargantext.Components.NgramsTable.Core"

139 140
type Endo a = a -> a

141 142
type CoreParams s =
  { nodeId  :: Int
143
    -- ^ This node can be a corpus or contact.
144 145
  , listIds :: Array Int
  , tabType :: TabType
146
  , session :: Session
147
  | s
148 149
  }

150 151
type PageParams =
  CoreParams
152 153
    ( params         :: T.Params
    , searchQuery    :: String
154 155
    , termListFilter :: Maybe TermList -- Nothing means all
    , termSizeFilter :: Maybe TermSize -- Nothing means all
156
    , scoreType      :: ScoreType
157 158
    )

159 160
initialPageParams :: Session -> Int -> Array Int -> TabType -> PageParams
initialPageParams session nodeId listIds tabType =
161 162
  { listIds
  , nodeId
163
  , params
164 165
  , tabType
  , termSizeFilter: Nothing
166
  , termListFilter: Just MapTerm
167
  , searchQuery: ""
168
  , scoreType: Occurrences
169
  , session
170
  }
171 172
  where
    params = T.initialParams { orderBy = Just (T.DESC $ T.ColumnName "Score") }
173

174 175
newtype NgramsTerm = NormNgramsTerm String

176 177 178 179 180 181 182
derive instance genericNgramsTerm :: Generic NgramsTerm _
instance eqNgramsTerm  :: Eq NgramsTerm where
  eq = genericEq
instance ordNgramsTerm :: Ord NgramsTerm where
  compare = genericCompare
instance showNgramsTerm :: Show NgramsTerm where
  show = genericShow
183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200

instance encodeJsonNgramsTerm :: EncodeJson NgramsTerm where
  encodeJson (NormNgramsTerm s) = encodeJson s

-- TODO we assume that the ngrams are already normalized.
instance decodeJsonNgramsTerm :: DecodeJson NgramsTerm where
  decodeJson = map NormNgramsTerm <<< decodeJson

ngramsTermText :: NgramsTerm -> String
ngramsTermText (NormNgramsTerm t) = t

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

201 202 203
normNgramWithTrim :: CTabNgramType -> String -> String
normNgramWithTrim nt = DSC.trim <<< normNgramInternal nt

204
normNgram :: CTabNgramType -> String -> NgramsTerm
205
normNgram tabType = NormNgramsTerm <<< normNgramWithTrim tabType
206 207 208

-----------------------------------------------------------------------------------
newtype NgramsElement = NgramsElement
209 210 211 212 213 214 215
  { ngrams      :: NgramsTerm -- HERE
  , size        :: Int -- MISSING
  , list        :: TermList -- ok
  , root        :: Maybe NgramsTerm -- ok
  , parent      :: Maybe NgramsTerm -- ok
  , children    :: Set NgramsTerm -- ok
  , occurrences :: Int -- HERE
216 217 218 219 220
  }

derive instance eqNgramsElement :: Eq NgramsElement


221
_parent :: forall parent row. Lens' { parent :: parent | row } parent
222
_parent = prop (SProxy :: SProxy "parent")
223 224

_root :: forall root row. Lens' { root :: root | row } root
225
_root   = prop (SProxy :: SProxy "root")
226 227

_ngrams :: forall row. Lens' { ngrams :: NgramsTerm | row } NgramsTerm
228 229 230 231 232 233 234 235 236 237 238
_ngrams = prop (SProxy :: SProxy "ngrams")

_children :: forall row. Lens' { children :: Set NgramsTerm | row } (Set NgramsTerm)
_children = prop (SProxy :: SProxy "children")

_occurrences :: forall row. Lens' { occurrences :: Int | row } Int
_occurrences = prop (SProxy :: SProxy "occurrences")

_list :: forall a row. Lens' { list :: a | row } a
_list = prop (SProxy :: SProxy "list")

Nicolas Pouillard's avatar
Nicolas Pouillard committed
239 240 241 242 243 244
_ngrams_repo_elements :: forall a row. Lens' { ngrams_repo_elements :: a | row } a
_ngrams_repo_elements = prop (SProxy :: SProxy "ngrams_repo_elements")

_ngrams_scores :: forall a row. Lens' { ngrams_scores :: a | row } a
_ngrams_scores = prop (SProxy :: SProxy "ngrams_scores")

245
derive instance newtypeNgramsElement :: Newtype NgramsElement _
246 247 248
derive instance genericNgramsElement :: Generic NgramsElement _
instance showNgramsElement :: Show NgramsElement where
  show = genericShow
249

250 251
_NgramsElement  :: Iso' NgramsElement {
    children    :: Set NgramsTerm
252
  , size        :: Int
253 254 255 256 257 258
  , list        :: TermList
  , ngrams      :: NgramsTerm
  , occurrences :: Int
  , parent      :: Maybe NgramsTerm
  , root        :: Maybe NgramsTerm
  }
259 260 261 262 263
_NgramsElement = _Newtype

instance decodeJsonNgramsElement :: DecodeJson NgramsElement where
  decodeJson json = do
    obj         <- decodeJson json
264
    ngrams      <- obj .:  "ngrams"
265
    size        <- obj .:  "size"
266 267
    list        <- obj .:  "list"
    occurrences <- obj .:  "occurrences"
268 269
    parent      <- obj .:? "parent"
    root        <- obj .:? "root"
270
    children'   <- obj .:  "children"
271
    let children = Set.fromFoldable (children' :: Array NgramsTerm)
272
    pure $ NgramsElement {ngrams, size, list, occurrences, parent, root, children}
273

274 275 276 277 278 279 280 281 282 283
instance encodeJsonNgramsElement :: EncodeJson NgramsElement where
  encodeJson (NgramsElement { children, list, ngrams, occurrences, parent, root }) = 
       "children"    := children
    ~> "list"        := list
    ~> "ngrams"      := ngrams
    ~> "occurrences" := occurrences
    ~> "parent"      :=? parent
    ~>? "root"        :=? root
    ~>? jsonEmptyObject

284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330
newtype NgramsRepoElement = NgramsRepoElement
  { size     :: Int
  , list     :: TermList
  , root     :: Maybe NgramsTerm
  , parent   :: Maybe NgramsTerm
  , children :: Set NgramsTerm
--  , occurrences :: Int -- TODO
  }

derive instance eqNgramsRepoElement  :: Eq NgramsRepoElement

instance decodeJsonNgramsRepoElement :: DecodeJson NgramsRepoElement where
  decodeJson json = do
    obj         <- decodeJson json
    size        <- obj .:  "size"
    list        <- obj .:  "list"
    parent      <- obj .:? "parent"
    root        <- obj .:? "root"
    children'   <- obj .:  "children"
    let children = Set.fromFoldable (children' :: Array NgramsTerm)
    pure $ NgramsRepoElement {size, list, parent, root, children}

instance encodeJsonNgramsRepoElement :: EncodeJson NgramsRepoElement where
  encodeJson (NgramsRepoElement { size, list, root, parent, children {-occurrences-} })
     =  "size"       :=  size
    ~>  "list"       :=  list
    ~>  "root"       :=? root
    ~>? "parent"     :=? parent
    ~>? "children"   :=  children
--    ~>  "occurrences" := occurrences
    ~>  jsonEmptyObject

derive instance newtypeNgramsRepoElement :: Newtype NgramsRepoElement _
derive instance genericNgramsRepoElement :: Generic NgramsRepoElement _
instance showNgramsRepoElement :: Show NgramsRepoElement where
  show = genericShow

_NgramsRepoElement  :: Iso' NgramsRepoElement {
    children    :: Set NgramsTerm
  , size        :: Int
  , list        :: TermList
  , parent      :: Maybe NgramsTerm
  , root        :: Maybe NgramsTerm
--  , occurrences :: Int
  }
_NgramsRepoElement = _Newtype

Nicolas Pouillard's avatar
Nicolas Pouillard committed
331
ngramsRepoElementToNgramsElement :: NgramsTerm -> Int -> NgramsRepoElement -> NgramsElement
332
ngramsRepoElementToNgramsElement ngrams occurrences (NgramsRepoElement { children, list, parent, root, size }) =
333
  NgramsElement
334
  { children
335
  , list
336
  , ngrams
Nicolas Pouillard's avatar
Nicolas Pouillard committed
337
  , occurrences
338 339 340
  , parent
  , root
  , size -- TODO should we assert that size(ngrams) == size?
341 342
  }

343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359
-----------------------------------------------------------------------------------
type Version = Int

newtype Versioned a = Versioned
  { version :: Version
  , data    :: a
  }

instance encodeJsonVersioned :: EncodeJson a => EncodeJson (Versioned a) where
  encodeJson (Versioned {version, data: data_})
     = "version" := version
    ~> "data" := data_
    ~> jsonEmptyObject

instance decodeJsonVersioned :: DecodeJson a => DecodeJson (Versioned a) where
  decodeJson json = do
    obj     <- decodeJson json
360 361
    version <- obj .: "version"
    data_   <- obj .: "data"
362 363
    pure $ Versioned {version, data: data_}

Nicolas Pouillard's avatar
Nicolas Pouillard committed
364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379
{-
  NgramsRepoElement does not have the occurrences field.
  Instead NgramsTable has a ngrams_scores map.

  Pro:
  * Does not encumber NgramsRepoElement with the score which is not part of repo.
  * Enables for multiple scores through multiple maps.
  Cons:
  * Having a map on the side is equivalent to a `occurrences :: Maybe Int`, which is
    less precise.
  * It is a tiny bit less performant to access the score.
-}
newtype NgramsTable = NgramsTable
  { ngrams_repo_elements :: Map NgramsTerm NgramsRepoElement
  , ngrams_scores        :: Map NgramsTerm (Additive Int)
  }
380 381

derive instance newtypeNgramsTable :: Newtype NgramsTable _
382 383 384 385 386
derive instance genericNgramsTable :: Generic NgramsTable _
instance eqNgramsTable  :: Eq NgramsTable where
  eq = genericEq
instance showNgramsTable :: Show NgramsTable where
  show = genericShow
387

Nicolas Pouillard's avatar
Nicolas Pouillard committed
388 389 390 391
_NgramsTable :: Iso' NgramsTable
                     { ngrams_repo_elements :: Map NgramsTerm NgramsRepoElement
                     , ngrams_scores        :: Map NgramsTerm (Additive Int)
                     }
392 393
_NgramsTable = _Newtype

394
instance indexNgramsTable :: Index NgramsTable NgramsTerm NgramsRepoElement where
Nicolas Pouillard's avatar
Nicolas Pouillard committed
395
  ix k = _NgramsTable <<< _ngrams_repo_elements <<< ix k
396

397
instance atNgramsTable :: At NgramsTable NgramsTerm NgramsRepoElement where
Nicolas Pouillard's avatar
Nicolas Pouillard committed
398
  at k = _NgramsTable <<< _ngrams_repo_elements <<< at k
399 400 401 402 403

instance decodeJsonNgramsTable :: DecodeJson NgramsTable where
  decodeJson json = do
    elements <- decodeJson json
    pure $ NgramsTable
Nicolas Pouillard's avatar
Nicolas Pouillard committed
404 405 406
      { ngrams_repo_elements: Map.fromFoldable $ f <$> (elements :: Array NgramsElement)
      , ngrams_scores:        Map.fromFoldable $ g <$> elements
      }
407
    where
Nicolas Pouillard's avatar
Nicolas Pouillard committed
408 409 410
      f (NgramsElement {ngrams, size, list, root, parent, children}) =
        Tuple ngrams (NgramsRepoElement {size, list, root, parent, children})
      g (NgramsElement e) = Tuple e.ngrams (Additive e.occurrences)
411

Nicolas Pouillard's avatar
Nicolas Pouillard committed
412
{- NOT USED
413
instance encodeJsonNgramsTable :: EncodeJson NgramsTable where
Nicolas Pouillard's avatar
Nicolas Pouillard committed
414 415
  encodeJson (NgramsTable {ngrams_repo_elements, ngrams_scores}) = encodeJson $ Map.values ... TODO
-}
416 417
-----------------------------------------------------------------------------------

Nicolas Pouillard's avatar
Nicolas Pouillard committed
418 419 420 421 422 423 424 425 426 427
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

428 429 430
wordBoundaryChars :: String
wordBoundaryChars = "[ .,;:!?'\\{}()]"

431
wordBoundaryReg :: R.Regex
432
wordBoundaryReg = case R.regex ("(" <> wordBoundaryChars <> ")") (R.global <> R.multiline) of
433 434
  Left e  -> unsafePartial $ crashWith e
  Right r -> r
435

436
wordBoundaryReg2 :: R.Regex
437
wordBoundaryReg2 = case R.regex ("(" <> wordBoundaryChars <> ")\\1") (R.global <> R.multiline) of
438 439 440
  Left e  -> unsafePartial $ crashWith e
  Right r -> r

441 442
-- TODO: while this function works well with word boundaries,
--       it inserts too many spaces.
443
highlightNgrams :: CTabNgramType -> NgramsTable -> String -> Array (Tuple String (Maybe TermList))
Nicolas Pouillard's avatar
Nicolas Pouillard committed
444
highlightNgrams ntype table@(NgramsTable {ngrams_repo_elements: elts}) input0 =
445
    -- trace {pats, input0, input, ixs} \_ ->
446
    let sN = unsafePartial (foldl goFold {i0: 0, s: input, l: Nil} ixs) in
447
    A.reverse (A.fromFoldable (consNonEmpty (undb (init sN.s)) sN.l))
448
  where
449 450
    spR x = " " <> R.replace wordBoundaryReg "$1$1" x <> " "
    reR = R.replace wordBoundaryReg " "
451
    db = S.replaceAll (S.Pattern " ") (S.Replacement "  ")
452
    sp x = " " <> db x <> " "
453
    undb = R.replace wordBoundaryReg2 "$1"
454 455
    init x = S.take (S.length x - 1) x
    input = spR input0
Nicolas Pouillard's avatar
Nicolas Pouillard committed
456
    pats = A.fromFoldable (Map.keys elts)
457
    ixs = indicesOfAny (sp <<< ngramsTermText <$> pats) (normNgramInternal ntype input)
458 459 460 461

    consOnJustTail s xs@(Tuple _ (Just _) : _) =
      Tuple s Nothing : xs
    consOnJustTail _ xs = xs
462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481

    consNonEmpty x xs
      | S.null x  = xs
      | otherwise = Tuple x Nothing : xs

    -- NOTE that only the first matching pattern is used, the others are ignored!
    goFold :: Partial => _ -> Tuple Int (Array Int) -> _
    goFold { i0, s, l } (Tuple i pis)
      | i < i0    =
        -- Skip this pattern which is overlapping with a previous one.
        { i0, s, l }
      | otherwise =
      case A.index pis 0 of
        Nothing ->
          { i0, s, l }
        Just pi ->
          case A.index pats pi of
            Nothing ->
              crashWith "highlightNgrams: out of bounds pattern"
            Just pat ->
482
              let lpat = S.length (db (ngramsTermText pat)) in
Nicolas Pouillard's avatar
Nicolas Pouillard committed
483
              case lookupRootList pat table of
484 485
                Nothing ->
                  crashWith "highlightNgrams: pattern missing from table"
Nicolas Pouillard's avatar
Nicolas Pouillard committed
486
                Just ne_list ->
487 488 489 490 491 492 493 494 495 496 497
                  let
                    s1    = S.splitAt (i - i0) s
                    s2    = S.splitAt lpat     (S.drop 1 s1.after)
                    s3    = S.splitAt 1        s2.after
                    unspB = if i0 == 0 then S.drop 1 else identity
                    s3b   = s3.before
                  in
                  -- trace {s, i, i0, s1, s2, s3, pat, lpat, s3b} \_ ->
                  -- `undb s2.before` and pat might differ by casing only!
                  { i0: i + lpat + 2
                  , s:  s3.after
Nicolas Pouillard's avatar
Nicolas Pouillard committed
498
                  , l:  Tuple (undb s2.before) (Just ne_list) :
499 500
                        consOnJustTail s3b
                        (consNonEmpty (unspB (undb s1.before)) l)
501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
                  }

-----------------------------------------------------------------------------------

type VersionedNgramsTable = Versioned NgramsTable

-----------------------------------------------------------------------------------
data Replace a
  = Keep
  | Replace { old :: a, new :: a }

replace :: forall a. Eq a => a -> a -> Replace a
replace old new
  | old == new = Keep
  | otherwise  = Replace { old, new }

517 518 519
derive instance eqReplace :: Eq a => Eq (Replace a)

instance semigroupReplace :: Eq a => Semigroup (Replace a) where
520 521
  append Keep p = p
  append p Keep = p
522
  append (Replace { old }) (Replace { new }) | old /= new = unsafeThrow "old != new"
523
  append (Replace { new }) (Replace { old }) = replace old new
524

525
instance semigroupMonoid :: Eq a => Monoid (Replace a) where
526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546
  mempty = Keep

applyReplace :: forall a. Eq a => Replace a -> a -> a
applyReplace Keep a = a
applyReplace (Replace { old, new }) a
  | a == old  = new
  | otherwise = a

instance encodeJsonReplace :: EncodeJson a => EncodeJson (Replace a) where
  encodeJson Keep
    = "tag" := "Keep"
   ~> jsonEmptyObject
  encodeJson (Replace {old, new})
    = "old" := old
   ~> "new" := new
   ~> "tag" := "Replace"
   ~> jsonEmptyObject

instance decodeJsonReplace :: (DecodeJson a, Eq a) => DecodeJson (Replace a) where
  decodeJson json = do
    obj  <- decodeJson json
547 548
    mold <- obj .:! "old"
    mnew <- obj .:! "new"
549 550 551
    case Tuple mold mnew of
      Tuple (Just old) (Just new) -> pure $ replace old new
      Tuple Nothing Nothing       -> pure Keep
552
      _                           -> Left $ TypeMismatch "decodeJsonReplace"
553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580

-- Representing a PatchSet as `Map a Boolean` would have the advantage
-- of enforcing rem and add to be disjoint.
newtype PatchSet a = PatchSet
  { rem :: Set a
  , add :: Set a
  }

instance semigroupPatchSet :: Ord a => Semigroup (PatchSet a) where
  append (PatchSet p) (PatchSet q) = PatchSet
    { rem: q.rem <> p.rem
    , add: Set.difference q.add p.rem <> p.add
    }

instance monoidPatchSet :: Ord a => Monoid (PatchSet a) where
  mempty = PatchSet { rem: Set.empty, add: Set.empty }

instance encodeJsonPatchSet :: EncodeJson a => EncodeJson (PatchSet a) where
  encodeJson (PatchSet {rem, add})
    -- TODO only include non empty fields
    = "rem" := (Set.toUnfoldable rem :: Array a)
   ~> "add" := (Set.toUnfoldable add :: Array a)
   ~> jsonEmptyObject

instance decodeJsonPatchSet :: (Ord a, DecodeJson a) => DecodeJson (PatchSet a) where
  decodeJson json = do
    -- TODO handle empty fields
    obj <- decodeJson json
581 582
    rem <- mkSet <$> (obj .: "rem")
    add <- mkSet <$> (obj .: "add")
583 584 585 586 587 588 589 590 591 592 593 594 595
    pure $ PatchSet { rem, add }
   where
    mkSet :: forall b. Ord b => Array b -> Set b
    mkSet = Set.fromFoldable

applyPatchSet :: forall a. Ord a => PatchSet a -> Set a -> Set a
applyPatchSet (PatchSet p) s = Set.difference s p.rem <> p.add

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

596 597 598 599 600 601 602 603 604 605 606 607 608
data NgramsPatch
  = NgramsReplace
      { patch_old :: Maybe NgramsRepoElement
      , patch_new :: Maybe NgramsRepoElement
      }
  | NgramsPatch
      { patch_children :: PatchSet NgramsTerm
      , patch_list     :: Replace TermList
      }

-- TODO shall we normalise as in replace? shall we make a type class Replaceable?
ngramsReplace :: Maybe NgramsRepoElement -> Maybe NgramsRepoElement -> NgramsPatch
ngramsReplace patch_old patch_new = NgramsReplace {patch_old, patch_new}
609

610 611 612
derive instance eqNgramsPatch  :: Eq NgramsPatch
derive instance eqPatchSetNgramsTerm  :: Eq (PatchSet NgramsTerm)

613 614 615 616
-- TODO
invert :: forall a. a -> a
invert _ = unsafeThrow "invert: TODO"

617
instance semigroupNgramsPatch :: Semigroup NgramsPatch where
618 619 620
  append (NgramsReplace p) (NgramsReplace q)
    | p.patch_old /= q.patch_new = unsafeThrow "append/NgramsPatch: old != new"
    | otherwise                  = ngramsReplace q.patch_old p.patch_new
621
  append (NgramsPatch p)   (NgramsPatch q) = NgramsPatch
622 623 624
    { patch_children: p.patch_children <> q.patch_children
    , patch_list:     p.patch_list     <> q.patch_list
    }
625 626
  append (NgramsPatch p) (NgramsReplace q) = ngramsReplace q.patch_old (q.patch_new # _Just <<< _Newtype %~ applyNgramsPatch' p)
  append (NgramsReplace p) (NgramsPatch q) = ngramsReplace (p.patch_old # _Just <<< _Newtype %~ applyNgramsPatch' (invert q)) p.patch_new
627 628 629 630 631

instance monoidNgramsPatch :: Monoid NgramsPatch where
  mempty = NgramsPatch { patch_children: mempty, patch_list: mempty }

instance encodeJsonNgramsPatch :: EncodeJson NgramsPatch where
632 633 634 635
  encodeJson (NgramsReplace { patch_old, patch_new })
     = "patch_old" := patch_old
    ~> "patch_new" := patch_new
    ~> jsonEmptyObject
636
  encodeJson (NgramsPatch { patch_children, patch_list })
637
  -- TODO only include non empty fields
638 639 640 641 642 643 644 645
     = "patch_children" := patch_children
    ~> "patch_list"     := patch_list
    ~> jsonEmptyObject

instance decodeJsonNgramsPatch :: DecodeJson NgramsPatch where
  decodeJson json = do
    obj            <- decodeJson json
    -- TODO handle empty fields
646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671
    -- TODO handle patch_new
    patch_new <- obj .:? "patch_new"
    patch_old <- obj .:? "patch_old"
    if isJust patch_new || isJust patch_old then
      pure $ NgramsReplace { patch_old, patch_new }
    else do
      patch_list     <- obj .: "patch_list"
      patch_children <- obj .: "patch_children"
      pure $ NgramsPatch { patch_list, patch_children }

applyNgramsPatch' :: forall row.
                          { patch_children :: PatchSet NgramsTerm
                          , patch_list     :: Replace TermList
                          } ->
                     Endo { list     :: TermList
                          , children :: Set NgramsTerm
                          | row
                          }
applyNgramsPatch' p e =
  e { list     = applyReplace p.patch_list e.list
    , children = applyPatchSet p.patch_children e.children
    }

applyNgramsPatch :: NgramsPatch -> Maybe NgramsRepoElement -> Maybe NgramsRepoElement
applyNgramsPatch (NgramsReplace {patch_new}) _ = patch_new
applyNgramsPatch (NgramsPatch p)           m = m # _Just <<< _Newtype %~ applyNgramsPatch' p
672 673 674

newtype PatchMap k p = PatchMap (Map k p)

675 676 677
fromMap :: forall k p. Ord k => Eq p => Monoid p => Map k p -> PatchMap k p
fromMap = PatchMap <<< Map.filter (\v -> v /= mempty)

678
instance semigroupPatchMap :: (Ord k, Eq p, Monoid p) => Semigroup (PatchMap k p) where
679
  append (PatchMap p) (PatchMap q) = fromMap $ Map.unionWith append p q
680

681
instance monoidPatchMap :: (Ord k, Eq p, Monoid p) => Monoid (PatchMap k p) where
682 683 684
  mempty = PatchMap Map.empty

derive instance newtypePatchMap :: Newtype (PatchMap k p) _
685
derive instance eqPatchMap :: (Eq k, Eq p) => Eq (PatchMap k p)
686 687 688 689

_PatchMap :: forall k p. Iso' (PatchMap k p) (Map k p)
_PatchMap = _Newtype

690
{-
691
instance functorPatchMap :: Functor (PatchMap k) where
692
  map f (PatchMap m) = PatchMap (map f m) -- NO NORM: fromMap would not typecheck
693 694

instance functorWithIndexPatchMap :: FunctorWithIndex k (PatchMap k) where
695 696
  mapWithIndex f (PatchMap m) = PatchMap (mapWithIndex f m) -- NO NORM: fromMap would not typecheck
-}
697 698 699 700 701 702 703 704 705 706 707

instance foldlablePatchMap :: Foldable (PatchMap k) where
  foldr f z (PatchMap m) = foldr f z m
  foldl f z (PatchMap m) = foldl f z m
  foldMap f (PatchMap m) = foldMap f m

instance foldlableWithIndexPatchMap :: FoldableWithIndex k (PatchMap k) where
  foldrWithIndex f z (PatchMap m) = foldrWithIndex f z m
  foldlWithIndex f z (PatchMap m) = foldlWithIndex f z m
  foldMapWithIndex f (PatchMap m) = foldMapWithIndex f m

708 709 710 711 712 713 714 715 716
{- fromMap is preventing these to type check:

instance traversablePatchMap :: Ord k => Traversable (PatchMap k) where
  traverse f (PatchMap m) = fromMap <$> traverse f m
  sequence (PatchMap m) = fromMap <$> sequence m

instance traversableWithIndexPatchMap :: Ord k => TraversableWithIndex k (PatchMap k) where
  traverseWithIndex f (PatchMap m) = fromMap <$> traverseWithIndex f m
-}
717

718 719 720 721
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
722

723 724
-- TODO generalize
instance encodeJsonPatchMap :: EncodeJson p => EncodeJson (PatchMap NgramsTerm p) where
725
  encodeJson (PatchMap m) =
726
    encodeJson $ FO.fromFoldable $ map (lmap ngramsTermText) (Map.toUnfoldable m :: Array _)
727

728
instance decodeJsonPatchMap :: DecodeJson p => DecodeJson (PatchMap NgramsTerm p) where
729 730
  decodeJson json = do
    obj <- decodeJson json
731 732
    pure $ PatchMap $ foldlWithIndex (\k m v -> Map.insert (NormNgramsTerm k) v m) mempty (obj :: FO.Object p)
    -- TODO we assume that the ngrams are already normalized ^^^^^^^^^^^^^
733

734 735 736
singletonPatchMap :: forall k p. k -> p -> PatchMap k p
singletonPatchMap k p = PatchMap (Map.singleton k p)

737 738 739
isEmptyPatchMap :: forall k p. PatchMap k p -> Boolean
isEmptyPatchMap (PatchMap p) = Map.isEmpty p

740 741
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))
742
  where
743 744 745 746 747 748 749 750 751
    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
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)
752

753
type NgramsPatches = PatchMap NgramsTerm NgramsPatch
754
type VersionedNgramsPatches = Versioned NgramsPatches
755 756 757 758 759 760 761 762 763
newtype AsyncNgramsChartsUpdate = AsyncNgramsChartsUpdate {
    listId  :: Maybe ListId
  , tabType :: TabType
  }
instance encodeAsyncNgramsChartsUpdate :: EncodeJson AsyncNgramsChartsUpdate where
  encodeJson (AsyncNgramsChartsUpdate { listId, tabType }) = do
      "list_id"  := listId
    ~> "tab_type" := tabType
    ~> jsonEmptyObject
764 765 766

type NewElems = Map NgramsTerm TermList

767 768
-- TODO replace by NgramsPatches directly
type NgramsTablePatch = { ngramsPatches :: NgramsPatches }
769

770 771 772
isEmptyNgramsTablePatch :: NgramsTablePatch -> Boolean
isEmptyNgramsTablePatch {ngramsPatches} = isEmptyPatchMap ngramsPatches

773
fromNgramsPatches :: NgramsPatches -> NgramsTablePatch
774
fromNgramsPatches ngramsPatches = {ngramsPatches}
775

776 777 778 779
findNgramRoot :: NgramsTable -> NgramsTerm -> NgramsTerm
findNgramRoot (NgramsTable m) n =
  fromMaybe n (m.ngrams_repo_elements ^? at n <<< _Just <<< _NgramsRepoElement <<< _root <<< _Just)

780
findNgramTermList :: NgramsTable -> NgramsTerm -> Maybe TermList
781 782 783
findNgramTermList (NgramsTable m) n = m.ngrams_repo_elements ^? at r <<< _Just <<< _NgramsRepoElement <<< _list
  where
    r = findNgramRoot (NgramsTable m) n
784

785 786
singletonNgramsTablePatch :: NgramsTerm -> NgramsPatch -> NgramsTablePatch
singletonNgramsTablePatch n p = fromNgramsPatches $ singletonPatchMap n p
787

788
rootsOf :: NgramsTable -> Set NgramsTerm
Nicolas Pouillard's avatar
Nicolas Pouillard committed
789
rootsOf (NgramsTable m) = Map.keys $ Map.mapMaybe isRoot m.ngrams_repo_elements
790
  where
791
    isRoot (NgramsRepoElement { parent }) = parent
792 793 794 795 796

type RootParent = { root :: NgramsTerm, parent :: NgramsTerm }

type ReParent a = forall m. MonadState NgramsTable m => a -> m Unit

797 798 799 800 801 802
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
803
  nre <- use (at ngram)
804 805
  traverseOf_ (_Just <<< _NgramsRepoElement <<< _children <<< folded) (\child -> do
    at child <<< _Just <<< _NgramsRepoElement <<< _root ?= root
806
    reRootChildren (max_depth - 1) root child) nre
807 808 809

reParent :: Maybe RootParent -> ReParent NgramsTerm
reParent mrp child = do
810 811
  at child <<< _Just <<< _NgramsRepoElement %= ((_parent .~ (view _parent <$> mrp)) <<<
                                                (_root   .~ (view _root   <$> mrp)))
812
  reRootChildren reRootMaxDepth (fromMaybe child (mrp ^? _Just <<< _root)) child
813 814 815 816 817 818

-- 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
819
reParentNgramsPatch _      (NgramsReplace _) = pure unit -- TODO
820 821 822 823
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)
824
  let root_of_parent = s ^? (_Just <<< _NgramsRepoElement <<< _root <<< _Just)
825
  let rp = { root: fromMaybe parent root_of_parent, parent }
826 827 828
  traverse_ (reParent Nothing) rem
  traverse_ (reParent $ Just rp) add

829
reParentNgramsTablePatch :: ReParent NgramsPatches
830
reParentNgramsTablePatch = void <<< traversePatchMapWithIndex reParentNgramsPatch
831

832
{-
833 834 835 836 837 838 839 840 841 842 843 844
newElemsTable :: NewElems -> Map NgramsTerm NgramsElement
newElemsTable = mapWithIndex newElem
  where
    newElem ngrams list =
      NgramsElement
        { ngrams
        , list
        , occurrences: 1
        , parent:      Nothing
        , root:        Nothing
        , children:    mempty
        }
845
-}
846

847
applyNgramsTablePatch :: NgramsTablePatch -> NgramsTable -> NgramsTable
848
applyNgramsTablePatch { ngramsPatches } (NgramsTable m) =
849
  execState (reParentNgramsTablePatch ngramsPatches) $
Nicolas Pouillard's avatar
Nicolas Pouillard committed
850 851
  NgramsTable $ m { ngrams_repo_elements =
                      applyPatchMap applyNgramsPatch ngramsPatches m.ngrams_repo_elements }
852

853 854 855
applyNgramsPatches :: forall s. CoreState s -> NgramsTable -> NgramsTable
applyNgramsPatches {ngramsLocalPatch, ngramsStagePatch, ngramsValidPatch} =
  applyNgramsTablePatch (ngramsLocalPatch <> ngramsStagePatch <> ngramsValidPatch)
856
  -- First the valid patch, then the stage patch, and finally the local patch.
857 858 859
-----------------------------------------------------------------------------------

type CoreState s =
860 861 862 863 864 865 866
  { ngramsLocalPatch :: NgramsTablePatch
                     -- ^ These patches are local and not yet staged.
  , ngramsStagePatch :: NgramsTablePatch
                     -- ^ These patches are staged (scheduled for synchronization).
                     --   Requests are being performed at the moment.
  , ngramsValidPatch :: NgramsTablePatch
                     -- ^ These patches have been synchronized with the server.
867 868 869 870
  , ngramsVersion    :: Version
  | s
  }

871
{-
872 873
postNewNgrams :: forall s. Array NgramsTerm -> Maybe TermList -> CoreParams s -> Aff Unit
postNewNgrams newNgrams mayList {nodeId, listIds, tabType, session} =
874
  when (not (A.null newNgrams)) $ do
875
    (_ :: Array Unit) <- post session p newNgrams
876
    pure unit
877
  where p = PutNgrams tabType (head listIds) mayList (Just nodeId)
878

879 880
postNewElems :: forall s. NewElems -> CoreParams s -> Aff Unit
postNewElems newElems params = void $ traverseWithIndex postNewElem newElems
881
  where
882
    postNewElem ngrams list = postNewNgrams [ngrams] (Just list) params
883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898
-}

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

900 901
addNewNgramP :: NgramsTerm -> TermList -> NgramsTablePatch
addNewNgramP ngrams list =
902
  { ngramsPatches: singletonPatchMap ngrams (newNgramPatch list) }
903

904 905 906 907 908 909 910 911 912 913 914
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

915
putNgramsPatches :: forall s. CoreParams s -> VersionedNgramsPatches -> Aff VersionedNgramsPatches
916
putNgramsPatches { listIds, nodeId, session, tabType } = put session putNgrams
917
  where putNgrams = PutNgrams tabType (head listIds) Nothing (Just nodeId)
918

919 920 921 922 923 924 925 926 927
postNgramsChartsAsync :: forall s. CoreParams s -> Aff AsyncTaskWithType
postNgramsChartsAsync { listIds, nodeId, session, tabType } = do
    task <- post session putNgramsAsync acu
    pure $ AsyncTaskWithType { task, typ: UpdateNgramsCharts }
  where
    acu = AsyncNgramsChartsUpdate { listId: head listIds
                                  , tabType }
    putNgramsAsync = PostNgramsChartsAsync (Just nodeId)

928 929 930 931 932 933
syncPatches :: forall p s. CoreParams p -> R.State (CoreState s) -> (Unit -> Aff Unit) -> Effect Unit
syncPatches props ({ ngramsLocalPatch: ngramsLocalPatch@{ ngramsPatches }
                   , ngramsStagePatch
                   , ngramsValidPatch
                   , ngramsVersion
                   } /\ setState) callback = do
934
  when (isEmptyNgramsTablePatch ngramsStagePatch) $ do
935
    let pt = Versioned { data: ngramsPatches, version: ngramsVersion }
936
    launchAff_ $ do
937
      Versioned { data: newPatch, version: newVersion } <- putNgramsPatches props pt
938
      callback unit
939 940 941 942 943 944 945 946 947 948 949 950 951 952
      liftEffect $ do
        log2 "[syncPatches] setting state, newVersion" newVersion
        setState $ \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
                              -- First the already valid patch, then the local patch, then the newly received newPatch.
            , ngramsVersion    = newVersion
            }
        log2 "[syncPatches] ngramsVersion" newVersion
953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979
    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
        log2 "[syncPatches] setting state, newVersion" newVersion
        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
            }
        log2 "[syncPatches] ngramsVersion" newVersion
-}
980 981 982

commitPatch :: forall s. Versioned NgramsTablePatch -> R.State (CoreState s) -> Effect Unit
commitPatch (Versioned {version, data: tablePatch}) (_ /\ setState) = do
983 984
  setState $ \s ->
    s { ngramsLocalPatch = tablePatch <> s.ngramsLocalPatch }
985
    -- First we apply the patches we have locally and then the new patch (tablePatch).
986

987 988
loadNgramsTable :: PageParams -> Aff VersionedNgramsTable
loadNgramsTable
989
  { nodeId, listIds, termListFilter, termSizeFilter, session, scoreType
990
  , searchQuery, tabType, params: {offset, limit, orderBy}}
991
  = get session query
992 993 994 995 996 997 998 999 1000 1001 1002
    where
      query = GetNgramsTableAll { listIds
                                , tabType } (Just nodeId)
  -- where query = GetNgrams { limit
  --                         , offset: Just offset
  --                         , listIds
  --                         , orderBy: convOrderBy <$> orderBy
  --                         , searchQuery
  --                         , tabType
  --                         , termListFilter
  --                         , termSizeFilter } (Just nodeId)
1003

1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014
type NgramsListByTabType = Map TabType VersionedNgramsTable

loadNgramsTableAll :: PageParams -> Aff NgramsListByTabType
loadNgramsTableAll { nodeId, listIds, session, scoreType } = do
  let
    cTagNgramTypes =
      [ CTabTerms
      , CTabSources
      , CTabAuthors
      , CTabInstitutes
      ]
1015
    query tabType = GetNgramsTableAll { listIds, tabType } (Just nodeId)
1016 1017 1018 1019 1020

  Map.fromFoldable <$> for cTagNgramTypes \cTagNgramType -> do
    let tabType = TabCorpus $ TabNgramType cTagNgramType
    result :: VersionedNgramsTable <- get session $ query tabType
    pure $ Tuple tabType result
1021

1022
convOrderBy :: T.OrderByDirection T.ColumnName -> OrderBy
1023 1024
convOrderBy (T.ASC  (T.ColumnName "Score")) = ScoreAsc
convOrderBy (T.DESC (T.ColumnName "Score")) = ScoreDesc
1025 1026
convOrderBy (T.ASC  _) = TermAsc
convOrderBy (T.DESC _) = TermDesc
1027

1028 1029
data CoreAction
  = CommitPatch NgramsTablePatch
1030
  | Synchronize { afterSync  :: Unit -> Aff Unit }
1031
  | ResetPatches
1032 1033

data Action
1034
  = CoreAction CoreAction
1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046
  | SetParentResetChildren (Maybe NgramsTerm)
  -- ^ This sets `ngramsParent` and resets `ngramsChildren`.
  | ToggleChild Boolean NgramsTerm
  -- ^ Toggles the NgramsTerm in the `PatchSet` `ngramsChildren`.
  -- If the `Boolean` is `true` it means we want to add it if it is not here,
  -- if it is `false` it is meant to be removed if not here.
  | AddTermChildren
  | ToggleSelect NgramsTerm
  -- ^ Toggles the NgramsTerm in the `Set` `ngramsSelection`.
  | ToggleSelectAll


1047
type CoreDispatch = CoreAction -> Effect Unit
1048
type Dispatch = Action -> Effect Unit
1049

1050 1051 1052 1053 1054 1055 1056 1057
coreDispatch :: forall p s. CoreParams p -> R.State (CoreState s) -> CoreDispatch
coreDispatch path state (Synchronize { afterSync }) =
  syncPatches path state afterSync
coreDispatch _ state@({ngramsVersion} /\ _) (CommitPatch pt) =
  commitPatch (Versioned {version: ngramsVersion, data: pt}) state
coreDispatch _ (_ /\ setState) ResetPatches =
  setState $ \s -> s { ngramsLocalPatch = { ngramsPatches: mempty } }

1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068
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
1069
filterTermSize _                _  = true
1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087

type SyncResetButtonsProps =
  ( afterSync :: Unit -> Aff Unit
  , ngramsLocalPatch :: NgramsTablePatch
  , performAction :: CoreDispatch
  )

syncResetButtons :: Record SyncResetButtonsProps -> R.Element
syncResetButtons p = R.createElement syncResetButtonsCpt p []

syncResetButtonsCpt :: R.Component SyncResetButtonsProps
syncResetButtonsCpt = R.hooksComponentWithModule thisModule "syncResetButtons" cpt
  where
    cpt { afterSync, ngramsLocalPatch, performAction } _ = do
      synchronizing@(s /\ setSynchronizing) <- R.useState' false

      let
        hasChanges = ngramsLocalPatch /= mempty
1088
        hasChangesClass = if hasChanges then "" else " disabled"
1089

1090 1091
        resetClick _ = do
          performAction ResetPatches
1092 1093 1094 1095 1096

        synchronizeClick _ = delay unit $ \_ -> do
          setSynchronizing $ const true
          performAction $ Synchronize { afterSync: newAfterSync }

1097 1098 1099 1100
        newAfterSync x = do
          afterSync x
          liftEffect $ setSynchronizing $ const false

1101
      pure $ H.div {} [
1102 1103
        H.button { className: "btn btn-danger " <> hasChangesClass
                 , on: { click: resetClick }
1104
                 } [ H.text "Reset" ]
1105
      , H.button { className: "btn btn-primary " <> hasChangesClass
1106 1107
                 , on: { click: synchronizeClick }
                 } [ H.text "Sync" ]
1108
        ]