module Gargantext.Components.NgramsTable.Core ( PageParams , CoreParams , NgramsElement(..) , _NgramsElement , NgramsRepoElementT , NgramsRepoElement(..) , _NgramsRepoElement , ngramsRepoElementToNgramsElement , NgramsTable(..) , NewElems , NgramsPatch(..) , NgramsPatches , _NgramsTable , NgramsTerm(..) , normNgram , ngramsTermText , findNgramRoot , findNgramTermList , Version , Versioned(..) , Count , VersionedWithCount(..) , toVersioned , VersionedNgramsPatches , AsyncNgramsChartsUpdate(..) , VersionedNgramsTable , VersionedWithCountNgramsTable , NgramsTablePatch , CoreState , HighlightElement , highlightNgrams , initialPageParams , loadNgramsTable , loadNgramsTableAll , convOrderBy , Replace(..) -- Ideally we should keep the constructors hidden , replace , PatchSet(..) , PatchMap(..) , _PatchMap , patchSetFromMap , applyPatchSet --, applyNgramsTablePatch -- re-export only if we have a good reason not to use applyNgramsPatches , applyNgramsPatches , rootsOf , singletonPatchMap , fromNgramsPatches , singletonNgramsTablePatch , isEmptyNgramsTablePatch , _list , _occurrences , _children , _ngrams , _parent , _root , _ngrams_repo_elements , _ngrams_scores , commitPatch , putNgramsPatches , postNgramsChartsAsync , syncPatches , addNewNgramP , addNewNgramA , setTermListP , setTermListA , CoreAction(..) , CoreDispatch , Action(..) , Dispatch , coreDispatch , isSingleNgramsTerm , filterTermSize -- Reset Button TODO put elsewhere this file is too big , SyncResetButtonsProps , syncResetButtons , chartsAfterSync ) where import Gargantext.Prelude import Control.Monad.State (class MonadState, execState) import DOM.Simple.Console (log2) import Data.Array (head) import Data.Array as A import Data.Bifunctor (lmap) import Data.Either (Either(..)) import Data.Eq.Generic (genericEq) import Data.Foldable (class Foldable, foldMap, foldl, foldr) import Data.FoldableWithIndex (class FoldableWithIndex, foldMapWithIndex, foldlWithIndex, foldrWithIndex) import Data.Generic.Rep (class Generic) import Data.Lens (Iso', Lens', use, view, (%=), (%~), (.~), (?=), (^?)) import Data.Lens.At (class At, at) import Data.Lens.Common (_Just) import Data.Lens.Fold (folded, traverseOf_) import Data.Lens.Index (class Index, ix) import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) import Data.List ((:), List(Nil)) import Data.List as L import Data.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(..), fromMaybe, fromMaybe', isJust) import Data.Monoid.Additive (Additive(..)) import Data.Newtype (class Newtype) import Data.Ord.Generic (genericCompare) import Data.Set (Set) import Data.Set as Set import Data.Show.Generic (genericShow) import Data.String as S import Data.String.Common as DSC import Data.String.Regex (Regex, regex, replace) as R import Data.String.Regex.Flags (global, multiline) as R import Data.String.Utils as SU import Data.Symbol (SProxy(..)) import Data.These (These(..)) import Data.Traversable (for, traverse_, traverse) import Data.TraversableWithIndex (traverseWithIndex) import Data.Tuple (Tuple(..)) import Data.Tuple.Nested ((/\)) import Effect (Effect) import Effect.Aff (Aff, launchAff_) import Effect.Class (liftEffect) import Effect.Exception.Unsafe (unsafeThrow) import FFI.Simple.Functions (delay) import Foreign as F import Foreign.Object as FO import Gargantext.AsyncTasks as GAT import Gargantext.Components.Table as T import Gargantext.Components.Table.Types as T import Gargantext.Config.REST (RESTError, AffRESTError) import Gargantext.Config.Utils (handleRESTError) import Gargantext.Routes (SessionRoute(..)) import Gargantext.Sessions (Session, get, post, put) import Gargantext.Types (AsyncTask, AsyncTaskType(..), AsyncTaskWithType(..), CTabNgramType(..), FrontendError, ListId, OrderBy(..), ScoreType(..), TabSubType(..), TabType(..), TermList(..), TermSize(..)) import Gargantext.Utils.Either (eitherMap) import Gargantext.Utils.KarpRabin (indicesOfAny) import Gargantext.Utils.Reactix as R2 import Partial (crashWith) import Partial.Unsafe (unsafePartial) import Reactix (Component, Element, createElement) as R import Reactix as R import Reactix.DOM.HTML as H import Simple.JSON as JSON import Toestand as T here :: R2.Here here = R2.here "Gargantext.Components.NgramsTable.Core" type Endo a = a -> a -- | Main Types type Version = Int newtype Versioned a = Versioned { version :: Version , data :: a } derive instance Generic (Versioned a) _ derive instance Newtype (Versioned a) _ instance Eq a => Eq (Versioned a) where eq = genericEq derive newtype instance JSON.ReadForeign a => JSON.ReadForeign (Versioned a) derive newtype instance JSON.WriteForeign a => JSON.WriteForeign (Versioned a) ------------------------------------------------------------------------ type Count = Int newtype VersionedWithCount a = VersionedWithCount { version :: Version , count :: Count , data :: a } derive instance Generic (VersionedWithCount a) _ derive instance Newtype (VersionedWithCount a) _ instance Eq a => Eq (VersionedWithCount a) where eq = genericEq derive newtype instance JSON.ReadForeign a => JSON.ReadForeign (VersionedWithCount a) derive newtype instance JSON.WriteForeign a => JSON.WriteForeign (VersionedWithCount a) toVersioned :: forall a. VersionedWithCount a -> Tuple Count (Versioned a) toVersioned (VersionedWithCount { count, data: d, version }) = Tuple count $ Versioned { data: d, version } ------------------------------------------------------------------------ -- TODO replace by NgramsPatches directly type NgramsTablePatch = { ngramsPatches :: NgramsPatches } newtype PatchMap k p = PatchMap (Map k p) derive instance Generic (PatchMap k p) _ derive instance Newtype (PatchMap k p) _ derive instance (Eq k, Eq p) => Eq (PatchMap k p) -- TODO generalize instance JSON.WriteForeign p => JSON.WriteForeign (PatchMap NgramsTerm p) where writeImpl (PatchMap m) = JSON.writeImpl $ FO.fromFoldable $ map (lmap ngramsTermText) (Map.toUnfoldable m :: Array _) instance (JSON.ReadForeign p, Monoid p) => JSON.ReadForeign (PatchMap NgramsTerm p) where readImpl f = do inst <- JSON.readImpl f pure $ PatchMap $ foldlWithIndex (\k m v -> Map.insert (NormNgramsTerm k) v m) Map.empty (inst :: FO.Object p) -- TODO we assume that the ngrams are already normalized ^^^^^^^^^^^^^ 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 } derive instance Generic NgramsPatch _ derive instance Eq NgramsPatch instance Monoid NgramsPatch where mempty = NgramsPatch { patch_children: mempty, patch_list: mempty } instance Semigroup NgramsPatch where append (NgramsReplace p) (NgramsReplace q) | p.patch_old /= q.patch_new = unsafeThrow "append/NgramsPatch: old != new" | otherwise = ngramsReplace q.patch_old p.patch_new append (NgramsPatch p) (NgramsPatch q) = NgramsPatch { patch_children: p.patch_children <> q.patch_children , patch_list: p.patch_list <> q.patch_list } 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 instance JSON.WriteForeign NgramsPatch where writeImpl (NgramsReplace { patch_old, patch_new }) = JSON.writeImpl { patch_old, patch_new } writeImpl (NgramsPatch { patch_children, patch_list }) = JSON.writeImpl { patch_children, patch_list } instance JSON.ReadForeign NgramsPatch where readImpl f = do inst :: { patch_old :: Maybe NgramsRepoElement , patch_new :: Maybe NgramsRepoElement , patch_children :: PatchSet NgramsTerm , patch_list :: Replace TermList } <- JSON.readImpl f -- TODO handle empty fields -- TODO handle patch_new if isJust inst.patch_new || isJust inst.patch_old then pure $ NgramsReplace { patch_old: inst.patch_old, patch_new: inst.patch_new } else do pure $ NgramsPatch { patch_list: inst.patch_list, patch_children: inst.patch_children } ------------------------------------------------------------------------ newtype NgramsTerm = NormNgramsTerm String derive instance Generic NgramsTerm _ derive instance Newtype NgramsTerm _ instance Eq NgramsTerm where eq = genericEq instance Ord NgramsTerm where compare = genericCompare instance Show NgramsTerm where show = genericShow derive newtype instance JSON.ReadForeign NgramsTerm derive newtype instance JSON.WriteForeign NgramsTerm derive newtype instance Monoid NgramsTerm ------------------------------------------------------------------------ type CoreParams s = { nodeId :: Int -- ^ This node can be a corpus or contact. , listIds :: Array Int , tabType :: TabType , session :: Session | s } type PageParams = CoreParams ( params :: T.Params , searchQuery :: String , termListFilter :: Maybe TermList -- Nothing means all , termSizeFilter :: Maybe TermSize -- Nothing means all , scoreType :: ScoreType ) initialPageParams :: Session -> Int -> Array Int -> TabType -> PageParams initialPageParams session nodeId listIds tabType = { listIds , nodeId , params , tabType , termSizeFilter: Nothing , termListFilter: Just MapTerm , searchQuery: "" , scoreType: Occurrences , session } where params = T.initialParams { orderBy = Just (T.DESC $ T.ColumnName "Score") } 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 " " normNgramWithTrim :: CTabNgramType -> String -> String normNgramWithTrim nt = DSC.trim <<< normNgramInternal nt normNgram :: CTabNgramType -> String -> NgramsTerm normNgram tabType = NormNgramsTerm <<< normNgramWithTrim tabType ----------------------------------------------------------------------------------- newtype NgramsElement = NgramsElement { ngrams :: NgramsTerm -- HERE , size :: Int -- MISSING , list :: TermList -- ok , root :: Maybe NgramsTerm -- ok , parent :: Maybe NgramsTerm -- ok , children :: Set NgramsTerm -- ok , occurrences :: Int -- HERE } derive instance Eq NgramsElement _parent :: forall parent row. Lens' { parent :: parent | row } parent _parent = prop (SProxy :: SProxy "parent") _root :: forall root row. Lens' { root :: root | row } root _root = prop (SProxy :: SProxy "root") _ngrams :: forall row. Lens' { ngrams :: NgramsTerm | row } NgramsTerm _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") _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") derive instance Newtype NgramsElement _ derive instance Generic NgramsElement _ instance Show NgramsElement where show = genericShow _NgramsElement :: Iso' NgramsElement { children :: Set NgramsTerm , size :: Int , list :: TermList , ngrams :: NgramsTerm , occurrences :: Int , parent :: Maybe NgramsTerm , root :: Maybe NgramsTerm } _NgramsElement = _Newtype instance JSON.ReadForeign NgramsElement where readImpl f = do inst :: { children :: Array NgramsTerm , size :: Int , list :: TermList , ngrams :: NgramsTerm , occurrences :: Int , parent :: Maybe NgramsTerm , root :: Maybe NgramsTerm }<- JSON.readImpl f pure $ NgramsElement $ inst { children = Set.fromFoldable inst.children } instance JSON.WriteForeign NgramsElement where writeImpl (NgramsElement ne) = JSON.writeImpl $ ne { children = Set.toUnfoldable ne.children :: Array _ } type NgramsRepoElementT = ( size :: Int , list :: TermList , root :: Maybe NgramsTerm , parent :: Maybe NgramsTerm ) newtype NgramsRepoElement = NgramsRepoElement { children :: Set NgramsTerm | NgramsRepoElementT } derive instance Generic NgramsRepoElement _ derive instance Newtype NgramsRepoElement _ derive instance Eq NgramsRepoElement instance JSON.ReadForeign NgramsRepoElement where readImpl f = do inst :: { children :: Array NgramsTerm | NgramsRepoElementT } <- JSON.readImpl f pure $ NgramsRepoElement $ inst { children = Set.fromFoldable inst.children } instance JSON.WriteForeign NgramsRepoElement where writeImpl (NgramsRepoElement nre) = JSON.writeImpl $ nre { children = Set.toUnfoldable nre.children :: Array _ } instance 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 ngramsRepoElementToNgramsElement :: NgramsTerm -> Int -> NgramsRepoElement -> NgramsElement ngramsRepoElementToNgramsElement ngrams occurrences (NgramsRepoElement { children, list, parent, root, size }) = NgramsElement { children , list , ngrams , occurrences , parent , root , size -- TODO should we assert that size(ngrams) == size? } ----------------------------------------------------------------------------------- {- 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) } derive instance Newtype NgramsTable _ derive instance Generic NgramsTable _ instance Eq NgramsTable where eq = genericEq instance Show NgramsTable where show = genericShow _NgramsTable :: Iso' NgramsTable { ngrams_repo_elements :: Map NgramsTerm NgramsRepoElement , ngrams_scores :: Map NgramsTerm (Additive Int) } _NgramsTable = _Newtype instance Index NgramsTable NgramsTerm NgramsRepoElement where ix k = _NgramsTable <<< _ngrams_repo_elements <<< ix k instance At NgramsTable NgramsTerm NgramsRepoElement where at k = _NgramsTable <<< _ngrams_repo_elements <<< at k instance JSON.ReadForeign NgramsTable where readImpl ff = do inst <- JSON.readImpl ff pure $ NgramsTable { ngrams_repo_elements: Map.fromFoldable $ f <$> (inst :: Array NgramsElement) , ngrams_scores: Map.fromFoldable $ g <$> inst } where 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) {- NOT USED instance EncodeJson NgramsTable where encodeJson (NgramsTable {ngrams_repo_elements, ngrams_scores}) = encodeJson $ Map.values ... TODO -} ----------------------------------------------------------------------------------- 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 wordBoundaryChars :: String wordBoundaryChars = "[ .,;:!?'\\{}()]" wordBoundaryReg :: R.Regex wordBoundaryReg = case R.regex ("(" <> wordBoundaryChars <> ")") (R.global <> R.multiline) of Left e -> unsafePartial $ crashWith e Right r -> r wordBoundaryReg2 :: R.Regex wordBoundaryReg2 = case R.regex ("(" <> wordBoundaryChars <> ")\\1") (R.global <> R.multiline) of Left e -> unsafePartial $ crashWith e Right r -> r type HighlightElement = Tuple String (List (Tuple NgramsTerm TermList)) type HighlightAccumulator = List HighlightElement -- TODO: while this function works well with word boundaries, -- it inserts too many spaces. highlightNgrams :: CTabNgramType -> NgramsTable -> String -> Array HighlightElement highlightNgrams ntype table@(NgramsTable {ngrams_repo_elements: elts}) input0 = -- trace {pats, input0, input, ixs} \_ -> A.fromFoldable ((\(s /\ ls)-> undb s /\ ls) <$> unsafePartial (foldl goFold ((input /\ Nil) : Nil) ixs)) where spR x = " " <> R.replace wordBoundaryReg "$1$1" x <> " " -- reR = R.replace wordBoundaryReg " " db = S.replaceAll (S.Pattern " ") (S.Replacement " ") sp x = " " <> db x <> " " undb = R.replace wordBoundaryReg2 "$1" input = spR input0 pats = A.fromFoldable (Map.keys elts) ixs = indicesOfAny (sp <<< ngramsTermText <$> pats) (normNgramInternal ntype input) 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) = case lookupRootList pat table of Nothing -> crashWith "highlightNgrams: pattern missing from table" Just ne_list -> let (acc0 /\ acc1_2) = splitAcc i acc (acc1 /\ acc2) = splitAcc (lpat + 1) acc1_2 text = extractInputTextMatch i lpat input ng = normNgram ntype text in acc0 <> (addNgramElt ng ne_list <$> acc1) <> acc2 goFold :: Partial => HighlightAccumulator -> Tuple Int (Array Int) -> HighlightAccumulator 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 ----------------------------------------------------------------------------------- type VersionedNgramsTable = Versioned NgramsTable type VersionedWithCountNgramsTable = VersionedWithCount NgramsTable ----------------------------------------------------------------------------------- data Replace a = Keep | Replace { old :: a, new :: a } derive instance Generic (Replace a) _ replace :: forall a. Eq a => a -> a -> Replace a replace old new | old == new = Keep | otherwise = Replace { old, new } derive instance Eq a => Eq (Replace a) instance Eq a => Semigroup (Replace a) where append Keep p = p append p Keep = p append (Replace { old }) (Replace { new }) | old /= new = unsafeThrow "old != new" append (Replace { new }) (Replace { old }) = replace old new instance Eq a => Monoid (Replace a) where 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 JSON.WriteForeign a => JSON.WriteForeign (Replace a) where writeImpl Keep = JSON.writeImpl { tag: "Keep" } writeImpl (Replace {old, new}) = JSON.writeImpl { old, new, tag: "Replace" } instance (JSON.ReadForeign a, Eq a) => JSON.ReadForeign (Replace a) where readImpl f = do impl :: { old :: Maybe a, new :: Maybe a } <- JSON.readImpl f case Tuple impl.old impl.new of Tuple (Just old) (Just new) -> pure $ replace old new Tuple Nothing Nothing -> pure Keep _ -> F.fail $ F.ForeignError "decodeJsonReplace" -- 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 } derive instance Generic (PatchSet a) _ derive instance Newtype (PatchSet a) _ instance 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 Ord a => Monoid (PatchSet a) where mempty = PatchSet { rem: Set.empty, add: Set.empty } instance JSON.WriteForeign a => JSON.WriteForeign (PatchSet a) where writeImpl (PatchSet {rem, add}) = JSON.writeImpl { rem: (Set.toUnfoldable rem :: Array a) , add: (Set.toUnfoldable add :: Array a) } instance (Ord a, JSON.ReadForeign a) => JSON.ReadForeign (PatchSet a) where readImpl f = do -- TODO handle empty fields inst :: { rem :: Array a, add :: Array a } <- JSON.readImpl f let rem = mkSet inst.rem add = mkSet inst.add 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 -- 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} derive instance Eq (PatchSet NgramsTerm) -- TODO invert :: forall a. a -> a invert _ = unsafeThrow "invert: TODO" 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 fromMap :: forall k p. Ord k => Eq p => Monoid p => Map k p -> PatchMap k p fromMap = PatchMap <<< Map.filter (\v -> v /= mempty) instance (Ord k, Eq p, Monoid p) => Semigroup (PatchMap k p) where append (PatchMap p) (PatchMap q) = fromMap $ Map.unionWith append p q instance (Ord k, Eq p, Monoid p) => Monoid (PatchMap k p) where mempty = PatchMap Map.empty _PatchMap :: forall k p. Iso' (PatchMap k p) (Map k p) _PatchMap = _Newtype {- instance Functor (PatchMap k) where map f (PatchMap m) = PatchMap (map f m) -- NO NORM: fromMap would not typecheck instance FunctorWithIndex k (PatchMap k) where mapWithIndex f (PatchMap m) = PatchMap (mapWithIndex f m) -- NO NORM: fromMap would not typecheck -} instance 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 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 {- fromMap is preventing these to type check: instance Ord k => Traversable (PatchMap k) where traverse f (PatchMap m) = fromMap <$> traverse f m sequence (PatchMap m) = fromMap <$> sequence m instance Ord k => TraversableWithIndex k (PatchMap k) where traverseWithIndex f (PatchMap m) = fromMap <$> traverseWithIndex f m -} 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 singletonPatchMap :: forall k p. k -> p -> PatchMap k p singletonPatchMap k p = PatchMap (Map.singleton k p) isEmptyPatchMap :: forall k p. PatchMap k p -> Boolean isEmptyPatchMap (PatchMap p) = Map.isEmpty p 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)) where 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) -} applyPatchMap applyPatchValue (PatchMap pm) m = foldl go m (Map.toUnfoldable pm :: List (Tuple k p)) where go m' (Tuple k pv) = Map.alter (applyPatchValue pv) k m' type VersionedNgramsPatches = Versioned NgramsPatches newtype AsyncNgramsChartsUpdate = AsyncNgramsChartsUpdate { listId :: Maybe ListId , tabType :: TabType } derive instance Generic AsyncNgramsChartsUpdate _ derive instance Newtype AsyncNgramsChartsUpdate _ instance JSON.WriteForeign AsyncNgramsChartsUpdate where writeImpl (AsyncNgramsChartsUpdate { listId, tabType }) = JSON.writeImpl { list_id: listId, tab_type: tabType } type NewElems = Map NgramsTerm TermList ---------------------------------------------------------------------------------- isEmptyNgramsTablePatch :: NgramsTablePatch -> Boolean isEmptyNgramsTablePatch {ngramsPatches} = isEmptyPatchMap ngramsPatches fromNgramsPatches :: NgramsPatches -> NgramsTablePatch fromNgramsPatches ngramsPatches = {ngramsPatches} findNgramRoot :: NgramsTable -> NgramsTerm -> NgramsTerm findNgramRoot (NgramsTable m) n = fromMaybe n (m.ngrams_repo_elements ^? at n <<< _Just <<< _NgramsRepoElement <<< _root <<< _Just) findNgramTermList :: NgramsTable -> NgramsTerm -> Maybe TermList findNgramTermList (NgramsTable m) n = m.ngrams_repo_elements ^? at r <<< _Just <<< _NgramsRepoElement <<< _list where r = findNgramRoot (NgramsTable m) n singletonNgramsTablePatch :: NgramsTerm -> NgramsPatch -> NgramsTablePatch singletonNgramsTablePatch n p = fromNgramsPatches $ singletonPatchMap n p rootsOf :: NgramsTable -> Set NgramsTerm rootsOf (NgramsTable m) = Map.keys $ Map.mapMaybe isRoot m.ngrams_repo_elements where isRoot (NgramsRepoElement { parent }) = parent type RootParent = { root :: NgramsTerm, parent :: NgramsTerm } type ReParent a = forall m. MonadState NgramsTable m => a -> m Unit 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 nre <- use (at ngram) traverseOf_ (_Just <<< _NgramsRepoElement <<< _children <<< folded) (\child -> do at child <<< _Just <<< _NgramsRepoElement <<< _root ?= root reRootChildren (max_depth - 1) root child) nre reParent :: Maybe RootParent -> ReParent NgramsTerm reParent mrp child = do at child <<< _Just <<< _NgramsRepoElement %= ((_parent .~ (view _parent <$> mrp)) <<< (_root .~ (view _root <$> mrp))) reRootChildren reRootMaxDepth (fromMaybe child (mrp ^? _Just <<< _root)) child -- 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 reParentNgramsPatch _ (NgramsReplace _) = pure unit -- TODO 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) let root_of_parent = s ^? (_Just <<< _NgramsRepoElement <<< _root <<< _Just) let rp = { root: fromMaybe parent root_of_parent, parent } traverse_ (reParent Nothing) rem traverse_ (reParent $ Just rp) add reParentNgramsTablePatch :: ReParent NgramsPatches reParentNgramsTablePatch = void <<< traversePatchMapWithIndex reParentNgramsPatch {- newElemsTable :: NewElems -> Map NgramsTerm NgramsElement newElemsTable = mapWithIndex newElem where newElem ngrams list = NgramsElement { ngrams , list , occurrences: 1 , parent: Nothing , root: Nothing , children: mempty } -} applyNgramsTablePatch :: NgramsTablePatch -> NgramsTable -> NgramsTable applyNgramsTablePatch { ngramsPatches } (NgramsTable m) = execState (reParentNgramsTablePatch ngramsPatches) $ NgramsTable $ m { ngrams_repo_elements = applyPatchMap applyNgramsPatch ngramsPatches m.ngrams_repo_elements } applyNgramsPatches :: forall s. CoreState s -> NgramsTable -> NgramsTable applyNgramsPatches {ngramsLocalPatch, ngramsStagePatch, ngramsValidPatch} = applyNgramsTablePatch (ngramsLocalPatch <> ngramsStagePatch <> ngramsValidPatch) -- First the valid patch, then the stage patch, and finally the local patch. ----------------------------------------------------------------------------------- type CoreState s = { 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. , ngramsVersion :: Version | s } {- postNewNgrams :: forall s. Array NgramsTerm -> Maybe TermList -> CoreParams s -> Aff Unit postNewNgrams newNgrams mayList {nodeId, listIds, tabType, session} = when (not (A.null newNgrams)) $ do (_ :: Array Unit) <- post session p newNgrams pure unit where p = PutNgrams tabType (head listIds) mayList (Just nodeId) postNewElems :: forall s. NewElems -> CoreParams s -> Aff Unit postNewElems newElems params = void $ traverseWithIndex postNewElem newElems where postNewElem ngrams list = postNewNgrams [ngrams] (Just list) params -} 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 } } addNewNgramP :: NgramsTerm -> TermList -> NgramsTablePatch addNewNgramP ngrams list = { ngramsPatches: singletonPatchMap ngrams (newNgramPatch list) } 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 putNgramsPatches :: forall s. CoreParams s -> VersionedNgramsPatches -> AffRESTError VersionedNgramsPatches putNgramsPatches { listIds, nodeId, session, tabType } = put session putNgrams where putNgrams = PutNgrams tabType (head listIds) Nothing (Just nodeId) syncPatches :: forall p s. CoreParams p -> T.Box (CoreState s) -> (Unit -> Aff Unit) -> Effect Unit syncPatches props state callback = do { ngramsLocalPatch: ngramsLocalPatch@{ ngramsPatches } , ngramsStagePatch , ngramsVersion } <- T.read state when (isEmptyNgramsTablePatch ngramsStagePatch) $ do let pt = Versioned { data: ngramsPatches, version: ngramsVersion } launchAff_ $ do ePatches <- putNgramsPatches props pt case ePatches of Left err -> liftEffect $ log2 "[syncPatches] RESTError" err Right (Versioned { data: newPatch, version: newVersion }) -> do callback unit liftEffect $ do log2 "[syncPatches] setting state, newVersion" newVersion T.modify_ (\s -> -- I think that sometimes this setState does not fully go through. -- This is an issue because the version number does not get updated and the subsequent calls -- can mess up the patches. s { ngramsLocalPatch = fromNgramsPatches mempty , ngramsStagePatch = fromNgramsPatches mempty , ngramsValidPatch = fromNgramsPatches newPatch <> ngramsLocalPatch <> s.ngramsValidPatch -- First the already valid patch, then the local patch, then the newly received newPatch. , ngramsVersion = newVersion }) state log2 "[syncPatches] ngramsVersion" newVersion 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 -} commitPatch :: forall s. NgramsTablePatch -> T.Box (CoreState s) -> Effect Unit commitPatch tablePatch state = do T.modify_ (\s -> s { ngramsLocalPatch = tablePatch <> s.ngramsLocalPatch }) state -- First we apply the patches we have locally and then the new patch (tablePatch). loadNgramsTable :: PageParams -> AffRESTError VersionedNgramsTable loadNgramsTable { nodeId , listIds , session , tabType } = get session query where query = GetNgramsTableAll { listIds , tabType } (Just nodeId) -- where query = GetNgrams { limit -- , offset: Just offset -- , listIds -- , orderBy: convOrderBy <$> orderBy -- , searchQuery -- , tabType -- , termListFilter -- , termSizeFilter } (Just nodeId) type NgramsListByTabType = Map TabType VersionedNgramsTable loadNgramsTableAll :: PageParams -> AffRESTError NgramsListByTabType loadNgramsTableAll { nodeId, listIds, session } = do let cTagNgramTypes = [ CTabTerms , CTabSources , CTabAuthors , CTabInstitutes ] query tabType = GetNgramsTableAll { listIds, tabType } (Just nodeId) ret <- Map.fromFoldable <$> for cTagNgramTypes \cTagNgramType -> do let tabType = TabCorpus $ TabNgramType cTagNgramType result :: Either RESTError VersionedNgramsTable <- get session $ query tabType pure $ Tuple tabType result pure $ eitherMap ret convOrderBy :: T.OrderByDirection T.ColumnName -> OrderBy convOrderBy (T.ASC (T.ColumnName "Score")) = ScoreAsc convOrderBy (T.DESC (T.ColumnName "Score")) = ScoreDesc convOrderBy (T.ASC _) = TermAsc convOrderBy (T.DESC _) = TermDesc data CoreAction = CommitPatch NgramsTablePatch | Synchronize { afterSync :: Unit -> Aff Unit } | ResetPatches data Action = CoreAction CoreAction | 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 type CoreDispatch = CoreAction -> Effect Unit type Dispatch = Action -> Effect Unit coreDispatch :: forall p s. CoreParams p -> T.Box (CoreState s) -> CoreDispatch coreDispatch path state (Synchronize { afterSync }) = syncPatches path state afterSync coreDispatch _ state (CommitPatch pt) = commitPatch pt state coreDispatch _ state ResetPatches = T.modify_ (_ { ngramsLocalPatch = { ngramsPatches: mempty } }) state 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 filterTermSize _ _ = true ------------------------------------------------------------------------ -- | Reset Button 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 = here.component "syncResetButtons" cpt where cpt { afterSync, ngramsLocalPatch, performAction } _ = do synchronizing <- T.useBox false synchronizing' <- T.useLive T.unequal synchronizing let hasChanges = ngramsLocalPatch /= mempty hasChangesClass = if hasChanges then "" else " disabled" synchronizingClass = if synchronizing' then " disabled" else "" resetClick _ = do performAction ResetPatches synchronizeClick _ = delay unit $ \_ -> do T.write_ true synchronizing performAction $ Synchronize { afterSync: newAfterSync } newAfterSync x = do afterSync x liftEffect $ T.write_ false synchronizing pure $ H.div { className: "btn-toolbar" } [ H.div { className: "btn-group mr-2" } [ H.button { className: "btn btn-danger " <> hasChangesClass <> synchronizingClass , on: { click: resetClick } } [ H.text "Reset" ] ] , H.div { className: "btn-group mr-2" } [ H.button { className: "btn btn-primary " <> hasChangesClass <> synchronizingClass , on: { click: synchronizeClick } } [ H.text "Sync" ] ] ] 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 } -> T.Box (Array FrontendError) -> T.Box GAT.Storage -> discard -> Aff Unit chartsAfterSync path'@{ nodeId } errors tasks _ = do eTask <- postNgramsChartsAsync path' handleRESTError errors eTask $ \task -> liftEffect $ do log2 "[chartsAfterSync] Synchronize task" task GAT.insert nodeId task tasks postNgramsChartsAsync :: forall s. CoreParams s -> AffRESTError AsyncTaskWithType postNgramsChartsAsync { listIds, nodeId, session, tabType } = do eTask :: Either RESTError AsyncTask <- post session putNgramsAsync acu pure $ (\task -> AsyncTaskWithType { task, typ: UpdateNgramsCharts }) <$> eTask where acu = AsyncNgramsChartsUpdate { listId: head listIds , tabType } putNgramsAsync = PostNgramsChartsAsync (Just nodeId)