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

  -- Reset Button TODO put elsewhere this file is too big
75 76
  , SyncResetButtonsProps
  , syncResetButtons
77
  , chartsAfterSync
78 79 80
  )
  where

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

135 136
import Gargantext.Prelude

137
import Gargantext.AsyncTasks as GAT
138 139
import Gargantext.Components.Table       as T
import Gargantext.Components.Table.Types as T
140
import Gargantext.Routes (SessionRoute(..))
141
import Gargantext.Sessions (Session, get, post, put)
142
import Gargantext.Types (AsyncTaskType(..), AsyncTaskWithType(..), CTabNgramType(..), ListId, OrderBy(..), ScoreType(..), TabSubType(..), TabType(..), TermList(..), TermSize(..))
143
import Gargantext.Utils.KarpRabin (indicesOfAny)
James Laver's avatar
James Laver committed
144 145 146 147 148
import Gargantext.Utils.Reactix as R2
import Gargantext.Utils.Toestand as T2
  
here :: R2.Here
here = R2.here "Gargantext.Components.NgramsTable.Core"
149

150 151
type Endo a = a -> a

152 153 154 155 156 157 158 159

-- | Main Types
type Version = Int

newtype Versioned a = Versioned
  { version :: Version
  , data    :: a
  }
160 161 162
derive instance genericVersioned :: Generic (Versioned a) _
instance eqVersioned :: Eq a => Eq (Versioned a) where
  eq = genericEq
163 164 165 166 167 168 169 170 171 172 173
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
    version <- obj .: "version"
    data_   <- obj .: "data"
    pure $ Versioned {version, data: data_}
174 175 176 177 178 179 180 181
------------------------------------------------------------------------
type Count = Int

newtype VersionedWithCount a = VersionedWithCount
  { version :: Version
  , count   :: Count
  , data    :: a
  }
182 183 184
derive instance genericVersionedWithCount :: Generic (VersionedWithCount a) _
instance eqVersionedWithCount :: Eq a => Eq (VersionedWithCount a) where
  eq = genericEq
185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201
instance encodeJsonVersionedWithCount :: EncodeJson a => EncodeJson (VersionedWithCount a) where
  encodeJson (VersionedWithCount {count, version, data: data_})
     = "version" := version
    ~> "count" := count
    ~> "data" := data_
    ~> jsonEmptyObject

instance decodeJsonVersionedWithCount :: DecodeJson a => DecodeJson (VersionedWithCount a) where
  decodeJson json = do
    obj     <- decodeJson json
    count   <- obj .: "count"
    data_   <- obj .: "data"
    version <- obj .: "version"
    pure $ VersionedWithCount {count, version, data: data_}

toVersioned :: forall a. VersionedWithCount a -> Tuple Count (Versioned a)
toVersioned (VersionedWithCount { count, data: d, version }) = Tuple count $ Versioned { data: d, version }
202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241

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

newtype PatchMap k p = PatchMap (Map k p)

type NgramsPatches = PatchMap NgramsTerm NgramsPatch

data NgramsPatch
  = NgramsReplace
      { patch_old :: Maybe NgramsRepoElement
      , patch_new :: Maybe NgramsRepoElement
      }
  | NgramsPatch
      { patch_children :: PatchSet NgramsTerm
      , patch_list     :: Replace TermList
      }

------------------------------------------------------------------------
newtype NgramsTerm = NormNgramsTerm String
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

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



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

242 243
type CoreParams s =
  { nodeId  :: Int
244
    -- ^ This node can be a corpus or contact.
245 246
  , listIds :: Array Int
  , tabType :: TabType
247
  , session :: Session
248
  | s
249 250
  }

251 252
type PageParams =
  CoreParams
253 254
    ( params         :: T.Params
    , searchQuery    :: String
255 256
    , termListFilter :: Maybe TermList -- Nothing means all
    , termSizeFilter :: Maybe TermSize -- Nothing means all
257
    , scoreType      :: ScoreType
258 259
    )

260 261
initialPageParams :: Session -> Int -> Array Int -> TabType -> PageParams
initialPageParams session nodeId listIds tabType =
262 263
  { listIds
  , nodeId
264
  , params
265 266
  , tabType
  , termSizeFilter: Nothing
267
  , termListFilter: Just MapTerm
268
  , searchQuery: ""
269
  , scoreType: Occurrences
270
  , session
271
  }
272 273
  where
    params = T.initialParams { orderBy = Just (T.DESC $ T.ColumnName "Score") }
274

275 276 277 278 279 280 281 282 283 284 285 286 287



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 " "

288 289 290
normNgramWithTrim :: CTabNgramType -> String -> String
normNgramWithTrim nt = DSC.trim <<< normNgramInternal nt

291
normNgram :: CTabNgramType -> String -> NgramsTerm
292
normNgram tabType = NormNgramsTerm <<< normNgramWithTrim tabType
293 294 295

-----------------------------------------------------------------------------------
newtype NgramsElement = NgramsElement
296 297 298 299 300 301 302
  { ngrams      :: NgramsTerm -- HERE
  , size        :: Int -- MISSING
  , list        :: TermList -- ok
  , root        :: Maybe NgramsTerm -- ok
  , parent      :: Maybe NgramsTerm -- ok
  , children    :: Set NgramsTerm -- ok
  , occurrences :: Int -- HERE
303 304 305 306 307
  }

derive instance eqNgramsElement :: Eq NgramsElement


308
_parent :: forall parent row. Lens' { parent :: parent | row } parent
309
_parent = prop (SProxy :: SProxy "parent")
310 311

_root :: forall root row. Lens' { root :: root | row } root
312
_root   = prop (SProxy :: SProxy "root")
313 314

_ngrams :: forall row. Lens' { ngrams :: NgramsTerm | row } NgramsTerm
315 316 317 318 319 320 321 322 323 324 325
_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
326 327 328 329 330 331
_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")

332
derive instance newtypeNgramsElement :: Newtype NgramsElement _
333 334 335
derive instance genericNgramsElement :: Generic NgramsElement _
instance showNgramsElement :: Show NgramsElement where
  show = genericShow
336

337 338
_NgramsElement  :: Iso' NgramsElement {
    children    :: Set NgramsTerm
339
  , size        :: Int
340 341 342 343 344 345
  , list        :: TermList
  , ngrams      :: NgramsTerm
  , occurrences :: Int
  , parent      :: Maybe NgramsTerm
  , root        :: Maybe NgramsTerm
  }
346 347 348 349 350
_NgramsElement = _Newtype

instance decodeJsonNgramsElement :: DecodeJson NgramsElement where
  decodeJson json = do
    obj         <- decodeJson json
351
    ngrams      <- obj .:  "ngrams"
352
    size        <- obj .:  "size"
353 354
    list        <- obj .:  "list"
    occurrences <- obj .:  "occurrences"
355 356
    parent      <- obj .:? "parent"
    root        <- obj .:? "root"
357
    children'   <- obj .:  "children"
358
    let children = Set.fromFoldable (children' :: Array NgramsTerm)
359
    pure $ NgramsElement {ngrams, size, list, occurrences, parent, root, children}
360

361 362 363 364 365 366 367 368 369 370
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

371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417
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
418
ngramsRepoElementToNgramsElement :: NgramsTerm -> Int -> NgramsRepoElement -> NgramsElement
419
ngramsRepoElementToNgramsElement ngrams occurrences (NgramsRepoElement { children, list, parent, root, size }) =
420
  NgramsElement
421
  { children
422
  , list
423
  , ngrams
Nicolas Pouillard's avatar
Nicolas Pouillard committed
424
  , occurrences
425 426 427
  , parent
  , root
  , size -- TODO should we assert that size(ngrams) == size?
428 429
  }

430
-----------------------------------------------------------------------------------
Nicolas Pouillard's avatar
Nicolas Pouillard committed
431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446
{-
  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)
  }
447 448

derive instance newtypeNgramsTable :: Newtype NgramsTable _
449 450 451 452 453
derive instance genericNgramsTable :: Generic NgramsTable _
instance eqNgramsTable  :: Eq NgramsTable where
  eq = genericEq
instance showNgramsTable :: Show NgramsTable where
  show = genericShow
454

Nicolas Pouillard's avatar
Nicolas Pouillard committed
455 456 457 458
_NgramsTable :: Iso' NgramsTable
                     { ngrams_repo_elements :: Map NgramsTerm NgramsRepoElement
                     , ngrams_scores        :: Map NgramsTerm (Additive Int)
                     }
459 460
_NgramsTable = _Newtype

461
instance indexNgramsTable :: Index NgramsTable NgramsTerm NgramsRepoElement where
Nicolas Pouillard's avatar
Nicolas Pouillard committed
462
  ix k = _NgramsTable <<< _ngrams_repo_elements <<< ix k
463

464
instance atNgramsTable :: At NgramsTable NgramsTerm NgramsRepoElement where
Nicolas Pouillard's avatar
Nicolas Pouillard committed
465
  at k = _NgramsTable <<< _ngrams_repo_elements <<< at k
466 467 468 469 470

instance decodeJsonNgramsTable :: DecodeJson NgramsTable where
  decodeJson json = do
    elements <- decodeJson json
    pure $ NgramsTable
Nicolas Pouillard's avatar
Nicolas Pouillard committed
471 472 473
      { ngrams_repo_elements: Map.fromFoldable $ f <$> (elements :: Array NgramsElement)
      , ngrams_scores:        Map.fromFoldable $ g <$> elements
      }
474
    where
Nicolas Pouillard's avatar
Nicolas Pouillard committed
475 476 477
      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)
478

Nicolas Pouillard's avatar
Nicolas Pouillard committed
479
{- NOT USED
480
instance encodeJsonNgramsTable :: EncodeJson NgramsTable where
Nicolas Pouillard's avatar
Nicolas Pouillard committed
481 482
  encodeJson (NgramsTable {ngrams_repo_elements, ngrams_scores}) = encodeJson $ Map.values ... TODO
-}
483 484
-----------------------------------------------------------------------------------

Nicolas Pouillard's avatar
Nicolas Pouillard committed
485 486 487 488 489 490 491 492 493 494
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

495 496 497
wordBoundaryChars :: String
wordBoundaryChars = "[ .,;:!?'\\{}()]"

498
wordBoundaryReg :: R.Regex
499
wordBoundaryReg = case R.regex ("(" <> wordBoundaryChars <> ")") (R.global <> R.multiline) of
500 501
  Left e  -> unsafePartial $ crashWith e
  Right r -> r
502

503
wordBoundaryReg2 :: R.Regex
504
wordBoundaryReg2 = case R.regex ("(" <> wordBoundaryChars <> ")\\1") (R.global <> R.multiline) of
505 506 507
  Left e  -> unsafePartial $ crashWith e
  Right r -> r

508 509
type HighlightElement = Tuple String (List (Tuple NgramsTerm TermList))
type HighlightAccumulator = List HighlightElement
510

511 512
-- TODO: while this function works well with word boundaries,
--       it inserts too many spaces.
513
highlightNgrams :: CTabNgramType -> NgramsTable -> String -> Array HighlightElement
Nicolas Pouillard's avatar
Nicolas Pouillard committed
514
highlightNgrams ntype table@(NgramsTable {ngrams_repo_elements: elts}) input0 =
515
    -- trace {pats, input0, input, ixs} \_ ->
516
    A.fromFoldable ((\(s /\ ls)-> undb s /\ ls) <$> unsafePartial (foldl goFold ((input /\ Nil) : Nil) ixs))
517
  where
518 519
    spR x = " " <> R.replace wordBoundaryReg "$1$1" x <> " "
    reR = R.replace wordBoundaryReg " "
520
    db = S.replaceAll (S.Pattern " ") (S.Replacement "  ")
521
    sp x = " " <> db x <> " "
522
    undb = R.replace wordBoundaryReg2 "$1"
523
    input = spR input0
Nicolas Pouillard's avatar
Nicolas Pouillard committed
524
    pats = A.fromFoldable (Map.keys elts)
525
    ixs = indicesOfAny (sp <<< ngramsTermText <$> pats) (normNgramInternal ntype input)
526

527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553
    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) =
554
      case lookupRootList pat table of
555
        Nothing ->
556 557 558
          crashWith "highlightNgrams: pattern missing from table"
        Just ne_list ->
          let
559 560 561 562
            (acc0 /\ acc1_2) = splitAcc i acc
            (acc1 /\ acc2) = splitAcc (lpat + 1) acc1_2
            text = extractInputTextMatch i lpat input
            ng = normNgram ntype text
563
          in
564 565
            acc0 <> (addNgramElt ng ne_list <$> acc1) <> acc2

566
    goFold :: Partial => HighlightAccumulator -> Tuple Int (Array Int) -> HighlightAccumulator
567 568 569 570 571
    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
572 573 574 575

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

type VersionedNgramsTable = Versioned NgramsTable
576
type VersionedWithCountNgramsTable = VersionedWithCount NgramsTable
577 578 579 580 581 582 583 584 585 586 587

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

588 589 590
derive instance eqReplace :: Eq a => Eq (Replace a)

instance semigroupReplace :: Eq a => Semigroup (Replace a) where
591 592
  append Keep p = p
  append p Keep = p
593
  append (Replace { old }) (Replace { new }) | old /= new = unsafeThrow "old != new"
594
  append (Replace { new }) (Replace { old }) = replace old new
595

596
instance semigroupMonoid :: Eq a => Monoid (Replace a) where
597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617
  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
618 619
    mold <- obj .:! "old"
    mnew <- obj .:! "new"
620 621 622
    case Tuple mold mnew of
      Tuple (Just old) (Just new) -> pure $ replace old new
      Tuple Nothing Nothing       -> pure Keep
623
      _                           -> Left $ TypeMismatch "decodeJsonReplace"
624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651

-- 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
652 653
    rem <- mkSet <$> (obj .: "rem")
    add <- mkSet <$> (obj .: "add")
654 655 656 657 658 659 660 661 662 663 664 665 666
    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

667 668 669
-- 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}
670

671 672 673
derive instance eqNgramsPatch  :: Eq NgramsPatch
derive instance eqPatchSetNgramsTerm  :: Eq (PatchSet NgramsTerm)

674
instance semigroupNgramsPatch :: Semigroup NgramsPatch where
675 676 677
  append (NgramsReplace p) (NgramsReplace q)
    | p.patch_old /= q.patch_new = unsafeThrow "append/NgramsPatch: old != new"
    | otherwise                  = ngramsReplace q.patch_old p.patch_new
678
  append (NgramsPatch p)   (NgramsPatch q) = NgramsPatch
679 680 681
    { patch_children: p.patch_children <> q.patch_children
    , patch_list:     p.patch_list     <> q.patch_list
    }
682 683
  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
684

685 686 687 688 689 690 691
-- TODO
invert :: forall a. a -> a
invert _ = unsafeThrow "invert: TODO"




692 693 694 695
instance monoidNgramsPatch :: Monoid NgramsPatch where
  mempty = NgramsPatch { patch_children: mempty, patch_list: mempty }

instance encodeJsonNgramsPatch :: EncodeJson NgramsPatch where
696 697 698 699
  encodeJson (NgramsReplace { patch_old, patch_new })
     = "patch_old" := patch_old
    ~> "patch_new" := patch_new
    ~> jsonEmptyObject
700
  encodeJson (NgramsPatch { patch_children, patch_list })
701
  -- TODO only include non empty fields
702 703 704 705 706 707 708 709
     = "patch_children" := patch_children
    ~> "patch_list"     := patch_list
    ~> jsonEmptyObject

instance decodeJsonNgramsPatch :: DecodeJson NgramsPatch where
  decodeJson json = do
    obj            <- decodeJson json
    -- TODO handle empty fields
710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735
    -- 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
736 737


738 739 740
fromMap :: forall k p. Ord k => Eq p => Monoid p => Map k p -> PatchMap k p
fromMap = PatchMap <<< Map.filter (\v -> v /= mempty)

741
instance semigroupPatchMap :: (Ord k, Eq p, Monoid p) => Semigroup (PatchMap k p) where
742
  append (PatchMap p) (PatchMap q) = fromMap $ Map.unionWith append p q
743

744
instance monoidPatchMap :: (Ord k, Eq p, Monoid p) => Monoid (PatchMap k p) where
745 746 747
  mempty = PatchMap Map.empty

derive instance newtypePatchMap :: Newtype (PatchMap k p) _
748
derive instance eqPatchMap :: (Eq k, Eq p) => Eq (PatchMap k p)
749 750 751 752

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

753
{-
754
instance functorPatchMap :: Functor (PatchMap k) where
755
  map f (PatchMap m) = PatchMap (map f m) -- NO NORM: fromMap would not typecheck
756 757

instance functorWithIndexPatchMap :: FunctorWithIndex k (PatchMap k) where
758 759
  mapWithIndex f (PatchMap m) = PatchMap (mapWithIndex f m) -- NO NORM: fromMap would not typecheck
-}
760 761 762 763 764 765 766 767 768 769 770

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

771 772 773 774 775 776 777 778 779
{- 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
-}
780

781 782 783 784
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
785

786 787
-- TODO generalize
instance encodeJsonPatchMap :: EncodeJson p => EncodeJson (PatchMap NgramsTerm p) where
788
  encodeJson (PatchMap m) =
789
    encodeJson $ FO.fromFoldable $ map (lmap ngramsTermText) (Map.toUnfoldable m :: Array _)
790

791
instance decodeJsonPatchMap :: DecodeJson p => DecodeJson (PatchMap NgramsTerm p) where
792 793
  decodeJson json = do
    obj <- decodeJson json
794 795
    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 ^^^^^^^^^^^^^
796

797 798 799
singletonPatchMap :: forall k p. k -> p -> PatchMap k p
singletonPatchMap k p = PatchMap (Map.singleton k p)

800 801 802
isEmptyPatchMap :: forall k p. PatchMap k p -> Boolean
isEmptyPatchMap (PatchMap p) = Map.isEmpty p

803 804
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))
805
  where
806 807 808 809
    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
810
{-
811 812 813 814 815
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)
816 817 818 819
-}
applyPatchMap applyPatchValue (PatchMap pm) m =
    foldl go m (Map.toUnfoldable pm :: List (Tuple k p))
  where
James Laver's avatar
James Laver committed
820
    go m' (Tuple k pv) = Map.alter (applyPatchValue pv) k m'
821

822
type VersionedNgramsPatches = Versioned NgramsPatches
823

824 825 826 827 828 829 830 831 832
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
833 834 835

type NewElems = Map NgramsTerm TermList

836
----------------------------------------------------------------------------------
837 838 839
isEmptyNgramsTablePatch :: NgramsTablePatch -> Boolean
isEmptyNgramsTablePatch {ngramsPatches} = isEmptyPatchMap ngramsPatches

840
fromNgramsPatches :: NgramsPatches -> NgramsTablePatch
841
fromNgramsPatches ngramsPatches = {ngramsPatches}
842

843 844 845 846
findNgramRoot :: NgramsTable -> NgramsTerm -> NgramsTerm
findNgramRoot (NgramsTable m) n =
  fromMaybe n (m.ngrams_repo_elements ^? at n <<< _Just <<< _NgramsRepoElement <<< _root <<< _Just)

847
findNgramTermList :: NgramsTable -> NgramsTerm -> Maybe TermList
848 849 850
findNgramTermList (NgramsTable m) n = m.ngrams_repo_elements ^? at r <<< _Just <<< _NgramsRepoElement <<< _list
  where
    r = findNgramRoot (NgramsTable m) n
851

852 853
singletonNgramsTablePatch :: NgramsTerm -> NgramsPatch -> NgramsTablePatch
singletonNgramsTablePatch n p = fromNgramsPatches $ singletonPatchMap n p
854

855
rootsOf :: NgramsTable -> Set NgramsTerm
Nicolas Pouillard's avatar
Nicolas Pouillard committed
856
rootsOf (NgramsTable m) = Map.keys $ Map.mapMaybe isRoot m.ngrams_repo_elements
857
  where
858
    isRoot (NgramsRepoElement { parent }) = parent
859 860 861 862 863

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

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

864 865 866 867 868 869
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
870
  nre <- use (at ngram)
871 872
  traverseOf_ (_Just <<< _NgramsRepoElement <<< _children <<< folded) (\child -> do
    at child <<< _Just <<< _NgramsRepoElement <<< _root ?= root
873
    reRootChildren (max_depth - 1) root child) nre
874 875 876

reParent :: Maybe RootParent -> ReParent NgramsTerm
reParent mrp child = do
877 878
  at child <<< _Just <<< _NgramsRepoElement %= ((_parent .~ (view _parent <$> mrp)) <<<
                                                (_root   .~ (view _root   <$> mrp)))
879
  reRootChildren reRootMaxDepth (fromMaybe child (mrp ^? _Just <<< _root)) child
880 881 882 883 884 885

-- 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
886
reParentNgramsPatch _      (NgramsReplace _) = pure unit -- TODO
887 888 889 890
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)
891
  let root_of_parent = s ^? (_Just <<< _NgramsRepoElement <<< _root <<< _Just)
892
  let rp = { root: fromMaybe parent root_of_parent, parent }
893 894 895
  traverse_ (reParent Nothing) rem
  traverse_ (reParent $ Just rp) add

896
reParentNgramsTablePatch :: ReParent NgramsPatches
897
reParentNgramsTablePatch = void <<< traversePatchMapWithIndex reParentNgramsPatch
898

899
{-
900 901 902 903 904 905 906 907 908 909 910 911
newElemsTable :: NewElems -> Map NgramsTerm NgramsElement
newElemsTable = mapWithIndex newElem
  where
    newElem ngrams list =
      NgramsElement
        { ngrams
        , list
        , occurrences: 1
        , parent:      Nothing
        , root:        Nothing
        , children:    mempty
        }
912
-}
913

914
applyNgramsTablePatch :: NgramsTablePatch -> NgramsTable -> NgramsTable
915
applyNgramsTablePatch { ngramsPatches } (NgramsTable m) =
916
  execState (reParentNgramsTablePatch ngramsPatches) $
Nicolas Pouillard's avatar
Nicolas Pouillard committed
917 918
  NgramsTable $ m { ngrams_repo_elements =
                      applyPatchMap applyNgramsPatch ngramsPatches m.ngrams_repo_elements }
919

920 921 922
applyNgramsPatches :: forall s. CoreState s -> NgramsTable -> NgramsTable
applyNgramsPatches {ngramsLocalPatch, ngramsStagePatch, ngramsValidPatch} =
  applyNgramsTablePatch (ngramsLocalPatch <> ngramsStagePatch <> ngramsValidPatch)
923
  -- First the valid patch, then the stage patch, and finally the local patch.
924 925 926
-----------------------------------------------------------------------------------

type CoreState s =
927 928 929 930 931 932 933
  { 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.
934 935 936 937
  , ngramsVersion    :: Version
  | s
  }

938
{-
939 940
postNewNgrams :: forall s. Array NgramsTerm -> Maybe TermList -> CoreParams s -> Aff Unit
postNewNgrams newNgrams mayList {nodeId, listIds, tabType, session} =
941
  when (not (A.null newNgrams)) $ do
942
    (_ :: Array Unit) <- post session p newNgrams
943
    pure unit
944
  where p = PutNgrams tabType (head listIds) mayList (Just nodeId)
945

946 947
postNewElems :: forall s. NewElems -> CoreParams s -> Aff Unit
postNewElems newElems params = void $ traverseWithIndex postNewElem newElems
948
  where
949
    postNewElem ngrams list = postNewNgrams [ngrams] (Just list) params
950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965
-}

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

967 968
addNewNgramP :: NgramsTerm -> TermList -> NgramsTablePatch
addNewNgramP ngrams list =
969
  { ngramsPatches: singletonPatchMap ngrams (newNgramPatch list) }
970

971 972 973 974 975 976 977 978 979 980 981
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

982
putNgramsPatches :: forall s. CoreParams s -> VersionedNgramsPatches -> Aff VersionedNgramsPatches
983
putNgramsPatches { listIds, nodeId, session, tabType } = put session putNgrams
984
  where putNgrams = PutNgrams tabType (head listIds) Nothing (Just nodeId)
985

986 987 988 989 990 991
syncPatches :: forall p s. CoreParams p -> T.Box (CoreState s) -> (Unit -> Aff Unit) -> Effect Unit
syncPatches props state callback = do
  { ngramsLocalPatch: ngramsLocalPatch@{ ngramsPatches }
  , ngramsStagePatch
  , ngramsValidPatch
  , ngramsVersion } <- T.read state
992
  when (isEmptyNgramsTablePatch ngramsStagePatch) $ do
993
    let pt = Versioned { data: ngramsPatches, version: ngramsVersion }
994
    launchAff_ $ do
995
      Versioned { data: newPatch, version: newVersion } <- putNgramsPatches props pt
996
      callback unit
997 998
      liftEffect $ do
        log2 "[syncPatches] setting state, newVersion" newVersion
999
        T.modify_ (\s ->
1000 1001 1002 1003 1004 1005 1006 1007 1008
          -- 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
1009
            }) state
1010
        log2 "[syncPatches] ngramsVersion" newVersion
1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037
    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
-}
1038

1039 1040 1041
commitPatch :: forall s. NgramsTablePatch -> T.Box (CoreState s) -> Effect Unit
commitPatch tablePatch state = do
  T.modify_ (\s -> s { ngramsLocalPatch = tablePatch <> s.ngramsLocalPatch }) state
1042
    -- First we apply the patches we have locally and then the new patch (tablePatch).
1043

1044 1045
loadNgramsTable :: PageParams -> Aff VersionedNgramsTable
loadNgramsTable
1046
  { nodeId, listIds, termListFilter, termSizeFilter, session, scoreType
1047
  , searchQuery, tabType, params: {offset, limit, orderBy}}
1048
  = get session query
1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059
    where
      query = GetNgramsTableAll { listIds
                                , tabType } (Just nodeId)
  -- where query = GetNgrams { limit
  --                         , offset: Just offset
  --                         , listIds
  --                         , orderBy: convOrderBy <$> orderBy
  --                         , searchQuery
  --                         , tabType
  --                         , termListFilter
  --                         , termSizeFilter } (Just nodeId)
1060

1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071
type NgramsListByTabType = Map TabType VersionedNgramsTable

loadNgramsTableAll :: PageParams -> Aff NgramsListByTabType
loadNgramsTableAll { nodeId, listIds, session, scoreType } = do
  let
    cTagNgramTypes =
      [ CTabTerms
      , CTabSources
      , CTabAuthors
      , CTabInstitutes
      ]
1072
    query tabType = GetNgramsTableAll { listIds, tabType } (Just nodeId)
1073 1074 1075 1076 1077

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

1079
convOrderBy :: T.OrderByDirection T.ColumnName -> OrderBy
1080 1081
convOrderBy (T.ASC  (T.ColumnName "Score")) = ScoreAsc
convOrderBy (T.DESC (T.ColumnName "Score")) = ScoreDesc
1082 1083
convOrderBy (T.ASC  _) = TermAsc
convOrderBy (T.DESC _) = TermDesc
1084

1085 1086
data CoreAction
  = CommitPatch NgramsTablePatch
1087
  | Synchronize { afterSync  :: Unit -> Aff Unit }
1088
  | ResetPatches
1089 1090

data Action
1091
  = CoreAction CoreAction
1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103
  | 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


1104
type CoreDispatch = CoreAction -> Effect Unit
1105
type Dispatch = Action -> Effect Unit
1106

1107
coreDispatch :: forall p s. CoreParams p -> T.Box (CoreState s) -> CoreDispatch
1108 1109
coreDispatch path state (Synchronize { afterSync }) =
  syncPatches path state afterSync
1110 1111 1112 1113
coreDispatch _ state (CommitPatch pt) =
  commitPatch pt state
coreDispatch _ state ResetPatches =
  T.modify_ (\s -> s { ngramsLocalPatch = { ngramsPatches: mempty } }) state
1114

1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125
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
1126
filterTermSize _                _  = true
1127

1128 1129 1130

------------------------------------------------------------------------
-- | Reset Button
1131
type SyncResetButtonsProps =
1132
  ( afterSync        :: Unit -> Aff Unit
1133
  , ngramsLocalPatch :: NgramsTablePatch
1134
  , performAction    :: CoreDispatch
1135 1136 1137 1138
  )

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

1140
syncResetButtonsCpt :: R.Component SyncResetButtonsProps
James Laver's avatar
James Laver committed
1141
syncResetButtonsCpt = here.component "syncResetButtons" cpt
1142
  where
1143
    cpt { afterSync, ngramsLocalPatch, performAction } _ = do
1144 1145
      -- synchronizing <- T.useBox false
      -- synchronizing' <- T.useLive T.unequal synchronizing
1146 1147 1148

      let
        hasChanges = ngramsLocalPatch /= mempty
1149
        hasChangesClass = if hasChanges then "" else " disabled"
1150

1151 1152
        resetClick _ = do
          performAction ResetPatches
1153 1154

        synchronizeClick _ = delay unit $ \_ -> do
1155
          -- T.write_ true synchronizing
1156 1157
          performAction $ Synchronize { afterSync: newAfterSync }

1158 1159
        newAfterSync x = do
          afterSync x
1160
          -- liftEffect $ T.write_ false synchronizing
1161

1162 1163 1164 1165 1166 1167 1168 1169
      pure $ H.div { className: "btn-toolbar" }
        [ H.div { className: "btn-group mr-2" }
          [ H.button { className: "btn btn-danger " <> hasChangesClass
                     , on: { click: resetClick }
                     } [ H.text "Reset" ]
          ]
        , H.div { className: "btn-group mr-2" }
          [ H.button { className: "btn btn-primary " <> hasChangesClass
1170 1171
                     , on: { click: synchronizeClick }
                     } [ H.text "Sync" ]
1172
          ]
1173
        ]
1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187


type ResetButton = (Unit -> Aff Unit)
               -> { ngramsPatches :: PatchMap NgramsTerm NgramsPatch }
               -> (Action -> Effect Unit)
               -> Array R.Element

chartsAfterSync :: forall props discard.
  { listIds :: Array Int
  , nodeId  :: Int
  , session :: Session
  , tabType :: TabType
  | props
  }
1188
  -> T.Box GAT.Storage
1189 1190
  -> discard
  -> Aff Unit
1191
chartsAfterSync path'@{ nodeId } tasks _ = do
1192 1193 1194
  task <- postNgramsChartsAsync path'
  liftEffect $ do
    log2 "[chartsAfterSync] Synchronize task" task
1195
    GAT.insert nodeId task tasks
1196 1197 1198 1199 1200 1201 1202 1203 1204 1205

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)