module Gargantext.Components.NgramsTable.Core ( PageParams , CoreParams , NgramsElement(..) , _NgramsElement , NgramsRepoElement(..) , _NgramsRepoElement , ngramsRepoElementToNgramsElement , NgramsPatch(..) , NgramsTable(..) , NgramsTablePatch , NewElems , NgramsPatches , _NgramsTable , NgramsTerm , normNgram , ngramsTermText , findNgramTermList , Version , Versioned(..) , VersionedNgramsPatches , VersionedNgramsTable , CoreState , highlightNgrams , initialPageParams , loadNgramsTable , loadNgramsTableAll , convOrderBy , Replace(..) -- Ideally we should keep the constructors hidden , replace , PatchSet(..) , PatchMap(..) , _PatchMap , patchSetFromMap , applyPatchSet , applyNgramsTablePatch , applyNgramsPatches , rootsOf , singletonPatchMap , fromNgramsPatches , singletonNgramsTablePatch , isEmptyNgramsTablePatch , _list , _occurrences , _children , _ngrams , _parent , _root , _ngrams_repo_elements , _ngrams_scores , commitPatchR , putNgramsPatches , syncPatchesR , addNewNgram , Action(..) , Dispatch , isSingleNgramsTerm , filterTermSize ) where import Prelude import Control.Monad.State (class MonadState, execState) import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson, jsonEmptyObject, (.:), (.:!), (.:?), (:=), (:=?), (~>), (~>?)) import Data.Argonaut.Decode.Error (JsonDecodeError(..)) import Data.Array (head) import Data.Array as A import Data.Bifunctor (lmap) import Data.Either (Either(..)) import Data.Foldable (class Foldable, foldMap, foldl, foldr) import Data.FoldableWithIndex (class FoldableWithIndex, foldMapWithIndex, foldlWithIndex, foldrWithIndex) --import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex) import Data.Generic.Rep (class Generic) import Data.Generic.Rep.Eq (genericEq) import Data.Generic.Rep.Ord (genericCompare) import Data.Generic.Rep.Show (genericShow) 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.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(..), fromMaybe, isJust) import Data.Monoid.Additive (Additive(..)) import Data.Newtype (class Newtype) import Data.Set (Set) import Data.Set as Set 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_) import Data.TraversableWithIndex (traverseWithIndex) import Data.Tuple (Tuple(..)) import Data.Tuple.Nested ((/\)) import Effect.Aff (Aff, launchAff_) import Effect (Effect) import Effect.Class (liftEffect) import Effect.Exception.Unsafe (unsafeThrow) import Foreign.Object as FO import Reactix (State) as R import Partial (crashWith) import Partial.Unsafe (unsafePartial) import Gargantext.Prelude import Gargantext.Components.Table as T import Gargantext.Routes (SessionRoute(..)) import Gargantext.Sessions (Session, get, put) import Gargantext.Types (CTabNgramType(..), OrderBy(..), ScoreType(..), TabSubType(..), TabType(..), TermList(..), TermSize(..)) import Gargantext.Utils.KarpRabin (indicesOfAny) type Endo a = a -> a 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 = { nodeId , listIds , params , tabType , termSizeFilter: Nothing , termListFilter: Just MapTerm , searchQuery: "" , scoreType: Occurrences , session } where params = T.initialParams { orderBy = Just (T.DESC $ T.ColumnName "Score") } 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 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 eqNgramsElement :: 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 newtypeNgramsElement :: Newtype NgramsElement _ derive instance genericNgramsElement :: Generic NgramsElement _ instance showNgramsElement :: 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 decodeJsonNgramsElement :: DecodeJson NgramsElement where decodeJson json = do obj <- decodeJson json ngrams <- obj .: "ngrams" size <- obj .: "size" list <- obj .: "list" occurrences <- obj .: "occurrences" parent <- obj .:? "parent" root <- obj .:? "root" children' <- obj .: "children" let children = Set.fromFoldable (children' :: Array NgramsTerm) pure $ NgramsElement {ngrams, size, list, occurrences, parent, root, children} 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 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 ngramsRepoElementToNgramsElement :: NgramsTerm -> Int -> NgramsRepoElement -> NgramsElement ngramsRepoElementToNgramsElement ngrams occurrences (NgramsRepoElement { size, list, root, parent, children }) = NgramsElement { ngrams , size -- TODO should we assert that size(ngrams) == size? , list , root , parent , children , occurrences } ----------------------------------------------------------------------------------- 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 version <- obj .: "version" data_ <- obj .: "data" pure $ Versioned {version, data: data_} {- 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 newtypeNgramsTable :: Newtype NgramsTable _ derive instance genericNgramsTable :: Generic NgramsTable _ instance eqNgramsTable :: Eq NgramsTable where eq = genericEq instance showNgramsTable :: Show NgramsTable where show = genericShow _NgramsTable :: Iso' NgramsTable { ngrams_repo_elements :: Map NgramsTerm NgramsRepoElement , ngrams_scores :: Map NgramsTerm (Additive Int) } _NgramsTable = _Newtype instance indexNgramsTable :: Index NgramsTable NgramsTerm NgramsRepoElement where ix k = _NgramsTable <<< _ngrams_repo_elements <<< ix k instance atNgramsTable :: At NgramsTable NgramsTerm NgramsRepoElement where at k = _NgramsTable <<< _ngrams_repo_elements <<< at k instance decodeJsonNgramsTable :: DecodeJson NgramsTable where decodeJson json = do elements <- decodeJson json pure $ NgramsTable { ngrams_repo_elements: Map.fromFoldable $ f <$> (elements :: Array NgramsElement) , ngrams_scores: Map.fromFoldable $ g <$> elements } 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 encodeJsonNgramsTable :: 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 -- TODO: while this function works well with word boundaries, -- it inserts too many spaces. highlightNgrams :: CTabNgramType -> NgramsTable -> String -> Array (Tuple String (Maybe TermList)) highlightNgrams ntype table@(NgramsTable {ngrams_repo_elements: elts}) input0 = -- trace {pats, input0, input, ixs} \_ -> let sN = unsafePartial (foldl goFold {i0: 0, s: input, l: Nil} ixs) in A.reverse (A.fromFoldable (consNonEmpty (undb (init sN.s)) sN.l)) where spR x = " " <> R.replace wordBoundaryReg "$1$1" x <> " " reR = R.replace wordBoundaryReg " " db = S.replace (S.Pattern " ") (S.Replacement " ") sp x = " " <> db x <> " " undb = R.replace wordBoundaryReg2 "$1" init x = S.take (S.length x - 1) x input = spR input0 pats = A.fromFoldable (Map.keys elts) ixs = indicesOfAny (sp <<< ngramsTermText <$> pats) (normNgramInternal ntype input) consOnJustTail s xs@(Tuple _ (Just _) : _) = Tuple s Nothing : xs consOnJustTail _ xs = xs 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 -> let lpat = S.length (db (ngramsTermText pat)) in case lookupRootList pat table of Nothing -> crashWith "highlightNgrams: pattern missing from table" Just ne_list -> 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 , l: Tuple (undb s2.before) (Just ne_list) : consOnJustTail s3b (consNonEmpty (unspB (undb s1.before)) l) } ----------------------------------------------------------------------------------- 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 } derive instance eqReplace :: Eq a => Eq (Replace a) instance semigroupReplace :: 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 semigroupMonoid :: 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 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 mold <- obj .:! "old" mnew <- obj .:! "new" case Tuple mold mnew of Tuple (Just old) (Just new) -> pure $ replace old new Tuple Nothing Nothing -> pure Keep _ -> Left $ TypeMismatch "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 } 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 rem <- mkSet <$> (obj .: "rem") add <- mkSet <$> (obj .: "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 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} derive instance eqNgramsPatch :: Eq NgramsPatch derive instance eqPatchSetNgramsTerm :: Eq (PatchSet NgramsTerm) -- TODO invert :: forall a. a -> a invert _ = unsafeThrow "invert: TODO" instance semigroupNgramsPatch :: Semigroup NgramsPatch where append (NgramsReplace p) (NgramsReplace q) = 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 monoidNgramsPatch :: Monoid NgramsPatch where mempty = NgramsPatch { patch_children: mempty, patch_list: mempty } instance encodeJsonNgramsPatch :: EncodeJson NgramsPatch where encodeJson (NgramsReplace { patch_old, patch_new }) = "patch_old" := patch_old ~> "patch_new" := patch_new ~> jsonEmptyObject encodeJson (NgramsPatch { patch_children, patch_list }) -- TODO only include non empty fields = "patch_children" := patch_children ~> "patch_list" := patch_list ~> jsonEmptyObject instance decodeJsonNgramsPatch :: DecodeJson NgramsPatch where decodeJson json = do obj <- decodeJson json -- TODO handle empty fields -- 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 newtype PatchMap k p = PatchMap (Map k 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 semigroupPatchMap :: (Ord k, Eq p, Monoid p) => Semigroup (PatchMap k p) where append (PatchMap p) (PatchMap q) = fromMap $ Map.unionWith append p q instance monoidPatchMap :: (Ord k, Eq p, Monoid p) => Monoid (PatchMap k p) where mempty = PatchMap Map.empty derive instance newtypePatchMap :: Newtype (PatchMap k p) _ derive instance eqPatchMap :: (Eq k, Eq p) => Eq (PatchMap k p) _PatchMap :: forall k p. Iso' (PatchMap k p) (Map k p) _PatchMap = _Newtype {- instance functorPatchMap :: Functor (PatchMap k) where map f (PatchMap m) = PatchMap (map f m) -- NO NORM: fromMap would not typecheck instance functorWithIndexPatchMap :: FunctorWithIndex k (PatchMap k) where mapWithIndex f (PatchMap m) = PatchMap (mapWithIndex f m) -- NO NORM: fromMap would not typecheck -} 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 {- 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 -} 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 -- TODO generalize instance encodeJsonPatchMap :: EncodeJson p => EncodeJson (PatchMap NgramsTerm p) where encodeJson (PatchMap m) = encodeJson $ FO.fromFoldable $ map (lmap ngramsTermText) (Map.toUnfoldable m :: Array _) instance decodeJsonPatchMap :: DecodeJson p => DecodeJson (PatchMap NgramsTerm p) where decodeJson json = do obj <- decodeJson json 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 ^^^^^^^^^^^^^ 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) type NgramsPatches = PatchMap NgramsTerm NgramsPatch type VersionedNgramsPatches = Versioned NgramsPatches type NewElems = Map NgramsTerm TermList -- TODO replace by NgramsPatches directly type NgramsTablePatch = { ngramsPatches :: NgramsPatches } isEmptyNgramsTablePatch :: NgramsTablePatch -> Boolean isEmptyNgramsTablePatch {ngramsPatches} = isEmptyPatchMap ngramsPatches fromNgramsPatches :: NgramsPatches -> NgramsTablePatch fromNgramsPatches ngramsPatches = {ngramsPatches} findNgramTermList :: NgramsTable -> NgramsTerm -> Maybe TermList findNgramTermList (NgramsTable m) n = m.ngrams_repo_elements ^? at n <<< _Just <<< _NgramsRepoElement <<< _list 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 } } addNewNgram :: NgramsTerm -> TermList -> NgramsTablePatch addNewNgram ngrams list = { ngramsPatches: singletonPatchMap ngrams (newNgramPatch list) } putNgramsPatches :: forall s. CoreParams s -> VersionedNgramsPatches -> Aff VersionedNgramsPatches putNgramsPatches {session, nodeId, listIds, tabType} = put session putNgrams where putNgrams = PutNgrams tabType (head listIds) Nothing (Just nodeId) -- TODO rename syncPatches syncPatchesR :: forall p s. CoreParams p -> R.State (CoreState s) -> Effect Unit syncPatchesR props ({ ngramsLocalPatch: ngramsLocalPatch@{ ngramsPatches } , ngramsStagePatch , ngramsValidPatch , ngramsVersion } /\ setState) = do when (isEmptyNgramsTablePatch ngramsStagePatch) $ do setState $ \s -> s { ngramsLocalPatch = fromNgramsPatches mempty , ngramsStagePatch = ngramsLocalPatch } let pt = Versioned { version: ngramsVersion, data: ngramsPatches } launchAff_ $ do Versioned {version: newVersion, data: newPatch} <- putNgramsPatches props pt liftEffect $ 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 { ngramsVersion = newVersion , ngramsValidPatch = fromNgramsPatches newPatch <> ngramsLocalPatch <> s.ngramsValidPatch -- First the already valid patch, then the local patch, then the newly received newPatch. , ngramsStagePatch = fromNgramsPatches mempty } -- TODO rename as commitPatch commitPatchR :: forall s. Versioned NgramsTablePatch -> R.State (CoreState s) -> Effect Unit commitPatchR (Versioned {version, data: tablePatch}) (_ /\ setState) = do setState $ \s -> s { ngramsLocalPatch = tablePatch <> s.ngramsLocalPatch } -- First we apply the patches we have locally and then the new patch (tablePatch). loadNgramsTable :: PageParams -> Aff VersionedNgramsTable loadNgramsTable { nodeId, listIds, termListFilter, termSizeFilter, session, scoreType , searchQuery, tabType, params: {offset, limit, orderBy}} = 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 -> Aff NgramsListByTabType loadNgramsTableAll { nodeId, listIds, session, scoreType } = do let cTagNgramTypes = [ CTabTerms , CTabSources , CTabAuthors , CTabInstitutes ] query tabType = GetNgramsTableAll { listIds, tabType } (Just nodeId) Map.fromFoldable <$> for cTagNgramTypes \cTagNgramType -> do let tabType = TabCorpus $ TabNgramType cTagNgramType result :: VersionedNgramsTable <- get session $ query tabType pure $ Tuple tabType result 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 Action = CommitPatch NgramsTablePatch | 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 | Synchronize | ToggleSelect NgramsTerm -- ^ Toggles the NgramsTerm in the `Set` `ngramsSelection`. | ToggleSelectAll | ResetPatches type Dispatch = Action -> Effect Unit 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