Skip to content

P
purescript-gargantext
Commit a90287bf authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge remote-tracking branch 'origin/409-dev-ngrams-table-edit-and-search' into dev-merge

parents 83a6e5e4 669563ce
Hide whitespace changes
Inline Side-by-side
Showing with 2007 additions and 206 deletions
src/Gargantext/Components/Annotation/Field.purs
View file @ a90287bf
......@@ -23,7 +23,8 @@ import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Gargantext.Components.Annotation.Menu (annotationMenu, AnnotationMenu)
import Gargantext.Components.Annotation.Types (termClass, MenuType(..))
import Gargantext.Components.NgramsTable.Core (NgramsTable, NgramsTerm, findNgramTermList, highlightNgrams, normNgram)
import Gargantext.Core.NgramsTable.Functions (findNgramTermList, highlightNgrams, normNgram)
import Gargantext.Core.NgramsTable.Types (NgramsTable, NgramsTerm)
import Gargantext.Types (CTabNgramType(..), TermList)
import Gargantext.Utils.Reactix as R2
import Gargantext.Utils.Selection as Sel
......
src/Gargantext/Components/Document/API.purs
View file @ a90287bf
......@@ -7,7 +7,7 @@ import Gargantext.Prelude
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Gargantext.Components.Document.Types (DocPath, LoadedData, NodeDocument)
import Gargantext.Components.NgramsTable.Core (loadNgramsTable)
import Gargantext.Core.NgramsTable.Functions (loadNgramsTable)
import Gargantext.Components.Search (SearchType(..))
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Routes (SessionRoute(..))
......
src/Gargantext/Components/Document/Layout.purs
View file @ a90287bf
......@@ -12,8 +12,10 @@ import Gargantext.Components.AutoUpdate (autoUpdate)
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap.Types (SpinnerTheme(..))
import Gargantext.Components.Document.Types (DocPath, Document(..), LoadedData, initialState)
import Gargantext.Components.NgramsTable.Core (CoreAction(..), Versioned(..), addNewNgramA, applyNgramsPatches, coreDispatch, findNgramRoot, replace, setTermListA, syncResetButtons, useAutoSync)
import Gargantext.Core.NgramsTable.Functions (addNewNgramA, applyNgramsPatches, coreDispatch, findNgramRoot, setTermListA)
import Gargantext.Components.NgramsTable.AutoSync (useAutoSync)
import Gargantext.Components.Node (NodePoly(..))
import Gargantext.Core.NgramsTable.Types (CoreAction(..), Versioned(..), replace)
import Gargantext.Utils as U
import Gargantext.Utils.Reactix as R2
import Reactix as R
......
src/Gargantext/Components/Document/Types.purs
View file @ a90287bf
......@@ -10,7 +10,7 @@ import Simple.JSON as JSON
import Gargantext.Prelude
import Gargantext.Components.Node (NodePoly(..))
import Gargantext.Components.NgramsTable.Core (CoreState, Versioned(..) , VersionedNgramsTable)
import Gargantext.Core.NgramsTable.Types (CoreState, Versioned(..) , VersionedNgramsTable)
import Gargantext.Sessions (Session)
import Gargantext.Types (ListId, NodeID, TabType)
......
src/Gargantext/Components/GraphExplorer/API.purs
View file @ a90287bf
......@@ -4,8 +4,8 @@ import Gargantext.Prelude
import Data.Maybe (Maybe(..))
import Gargantext.Components.GraphExplorer.Types as GET
import Gargantext.Components.NgramsTable.Core as NTC
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Core.NgramsTable.Types as CNT
import Gargantext.Hooks.Sigmax.Types as SigmaxT
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Routes as GR
......@@ -20,7 +20,7 @@ type GraphAsyncUpdateParams =
, nodes :: Array (Record SigmaxT.Node)
, session :: Session
, termList :: GT.TermList
, version :: NTC.Version
, version :: CNT.Version
)
graphAsyncUpdate :: Record GraphAsyncUpdateParams -> AffRESTError GT.AsyncTaskWithType
......
src/Gargantext/Components/GraphExplorer/Sidebar/Sidebar.purs → src/Gargantext/Components/GraphExplorer/Sidebar.purs
View file @ a90287bf
......@@ -28,8 +28,9 @@ import Gargantext.Components.GraphExplorer.Sidebar.Legend as Legend
import Gargantext.Components.GraphExplorer.Store as GraphStore
import Gargantext.Components.GraphExplorer.Types as GET
import Gargantext.Components.Lang (Lang(..))
import Gargantext.Components.NgramsTable.Core as NTC
import Gargantext.Core.NgramsTable.Functions as NTC
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Core.NgramsTable.Types as CNT
import Gargantext.Data.Array (mapMaybe)
import Gargantext.Ends (Frontends)
import Gargantext.Hooks.FirstEffect (useFirstEffect')
......@@ -634,14 +635,14 @@ type SendPatches =
sendPatches :: Record SendPatches -> Effect Unit
sendPatches { errors, metaData, nodes, reloadForest, session, termList } = do
launchAff_ do
patches <- (parTraverse (sendPatch termList session metaData) nodes) -- :: Aff (Array NTC.VersionedNgramsPatches)
patches <- (parTraverse (sendPatch termList session metaData) nodes) -- :: Aff (Array CNT.VersionedNgramsPatches)
let mPatch = last patches
case mPatch of
Nothing -> pure unit
Just (Left err) -> liftEffect $ do
T.modify_ (A.cons $ FRESTError { error: err }) errors
here.warn2 "[sendPatches] RESTError" err
Just (Right (NTC.Versioned _patch)) -> do
Just (Right (CNT.Versioned _patch)) -> do
liftEffect $ T2.reload reloadForest
-- Why is this called delete node?
......@@ -649,7 +650,7 @@ sendPatch :: TermList
-> Session
-> GET.MetaData
-> Record SigmaxT.Node
-> AffRESTError NTC.VersionedNgramsPatches
-> AffRESTError CNT.VersionedNgramsPatches
sendPatch termList session (GET.MetaData metaData) node = do
eRet <- NTC.putNgramsPatches coreParams versioned
case eRet of
......@@ -661,10 +662,10 @@ sendPatch termList session (GET.MetaData metaData) node = do
nodeId :: NodeID
nodeId = unsafePartial $ fromJust $ fromString node.id
versioned :: NTC.VersionedNgramsPatches
versioned = NTC.Versioned {version: metaData.list.version, data: np}
versioned :: CNT.VersionedNgramsPatches
versioned = CNT.Versioned {version: metaData.list.version, data: np}
coreParams :: NTC.CoreParams ()
coreParams :: CNT.CoreParams ()
coreParams = {session, nodeId, listIds: [metaData.list.listId], tabType}
tabNgramType :: CTabNgramType
......@@ -673,14 +674,14 @@ sendPatch termList session (GET.MetaData metaData) node = do
tabType :: TabType
tabType = TabCorpus (TabNgramType tabNgramType)
term :: NTC.NgramsTerm
term :: CNT.NgramsTerm
term = NTC.normNgram tabNgramType node.label
np :: NTC.NgramsPatches
np = NTC.singletonPatchMap term $ NTC.NgramsPatch { patch_children: mempty, patch_list }
np :: CNT.NgramsPatches
np = NTC.singletonPatchMap term $ CNT.NgramsPatch { patch_children: mempty, patch_list }
patch_list :: NTC.Replace TermList
patch_list = NTC.Replace { new: termList, old: MapTerm }
patch_list :: CNT.Replace TermList
patch_list = CNT.Replace { new: termList, old: MapTerm }
......
src/Gargantext/Components/NgramsTable.purs
View file @ a90287bf
module Gargantext.Components.NgramsTable
( MainNgramsTableProps
, CommonProps
, TreeEdit
, NgramsTreeEditProps
, getNgramsChildrenAff
, initialTreeEdit
, mainNgramsTable
) where
import Gargantext.Prelude
import Data.Array as A
import Data.Either (Either(..))
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (to, view, (%~), (.~), (^.), (^?))
import Data.Lens (to, view, (%~), (.~), (^.), (^?), (^..))
import Data.Lens.At (at)
import Data.Lens.Common (_Just)
import Data.Lens.Fold (folded)
import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe, isNothing, maybe)
......@@ -25,20 +32,25 @@ import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Gargantext.Components.App.Store (Boxes)
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap.Types (ButtonVariant(..), Variant(..))
import Gargantext.Components.NgramsTable.Components as NTC
import Gargantext.Components.NgramsTable.Core (Action(..), CoreAction(..), CoreState, Dispatch, NgramsElement(..), NgramsPatch(..), NgramsTable, NgramsTerm, PageParams, PatchMap(..), Versioned(..), VersionedNgramsTable, VersionedWithCountNgramsTable, _NgramsElement, _NgramsRepoElement, _NgramsTable, _children, _list, _ngrams, _ngrams_repo_elements, _ngrams_scores, _occurrences, _root, addNewNgramA, applyNgramsPatches, applyPatchSet, chartsAfterSync, commitPatch, convOrderBy, coreDispatch, filterTermSize, fromNgramsPatches, ngramsRepoElementToNgramsElement, ngramsTermText, normNgram, patchSetFromMap, replace, setTermListA, singletonNgramsTablePatch, syncResetButtons, toVersioned)
import Gargantext.Core.NgramsTable.Functions (addNewNgramA, applyNgramsPatches, chartsAfterSync, commitPatch, convOrderBy, coreDispatch, filterTermSize, ngramsRepoElementToNgramsElement, normNgram, patchSetFromMap, setTermListA, singletonNgramsTablePatch, tablePatchHasNgrams, toVersioned)
import Gargantext.Components.NgramsTable.Search as NTS
import Gargantext.Components.NgramsTable.SelectionCheckbox as NTSC
import Gargantext.Components.NgramsTable.Tree (renderNgramsItem, renderNgramsTree)
import Gargantext.Components.NgramsTable.Loader (useLoaderWithCacheAPI)
import Gargantext.Components.NgramsTable.SyncResetButton (syncResetButtons)
import Gargantext.Components.Nodes.Lists.Types as NT
import Gargantext.Components.Table as TT
import Gargantext.Components.Table.Types as TT
import Gargantext.Config.REST (AffRESTError, logRESTError)
import Gargantext.Config.REST (AffRESTError, RESTError, logRESTError)
import Gargantext.Core.NgramsTable.Types (Action(..), CoreAction(..), CoreState, Dispatch, NgramsActionRef, NgramsClick, NgramsDepth, NgramsElement(..), NgramsPatch(..), NgramsTable, NgramsTablePatch(..), NgramsTerm(..), PageParams, PatchMap(..), Versioned(..), VersionedNgramsTable, VersionedWithCountNgramsTable, _NgramsElement, _NgramsRepoElement, _NgramsTable, _children, _list, _ngrams, _ngrams_repo_elements, _ngrams_scores, _occurrences, _root, applyPatchSet, ngramsTermText, replace)
import Gargantext.Hooks.Loader (useLoaderBox)
import Gargantext.Routes (SessionRoute(..)) as R
import Gargantext.Sessions (Session, get)
import Gargantext.Types (CTabNgramType, OrderBy(..), SearchQuery, TabType, TermList(..), TermSize, termLists, termSizes)
import Gargantext.Types (CTabNgramType, ListId, NodeID, OrderBy(..), SearchQuery, TabType, TermList(..), TermSize, termLists, termSizes)
import Gargantext.Utils (queryExactMatchesLabel, queryMatchesLabel, toggleSet, sortWith)
import Gargantext.Utils.CacheAPI as GUC
import Gargantext.Utils.Reactix as R2
......@@ -46,38 +58,54 @@ import Gargantext.Utils.Seq as Seq
import Gargantext.Utils.Toestand as T2
import Reactix as R
import Reactix.DOM.HTML as H
import Record as Record
import Toestand as T
import Unsafe.Coerce (unsafeCoerce)
here :: R2.Here
here = R2.here "Gargantext.Components.NgramsTable"
type TreeEdit =
{ isEditing :: Boolean
, ngramsChildren :: List NgramsTerm
-- ^ Root children, as were originally present
-- in the table, before editing
, ngramsChildrenDiff :: Map NgramsTerm Boolean
-- ^ Used only when grouping.
-- This updates the children of `ngramsParent`,
-- ngrams set to `true` are to be added, and `false` to
-- be removed.
, ngramsParent :: Maybe NgramsTerm -- Nothing means we are not currently grouping terms
}
type State =
CoreState (
ngramsChildren :: Map NgramsTerm Boolean
-- ^ Used only when grouping.
-- This updates the children of `ngramsParent`,
-- ngrams set to `true` are to be added, and `false` to
-- be removed.
, ngramsParent :: Maybe NgramsTerm -- Nothing means we are not currently grouping terms
, ngramsSelection :: Set NgramsTerm
ngramsSelection :: Set NgramsTerm
-- ^ The set of selected checkboxes of the first column.
)
initialState :: VersionedNgramsTable -> State
initialState (Versioned {version}) = {
ngramsChildren: Map.empty
, ngramsLocalPatch: mempty
, ngramsParent: Nothing
initialTreeEdit :: TreeEdit
initialTreeEdit =
{ isEditing : false
, ngramsChildren : List.Nil
, ngramsChildrenDiff: Map.empty
, ngramsParent : Nothing }
initialState :: State
initialState =
{ ngramsLocalPatch: mempty
, ngramsSelection: mempty
, ngramsStagePatch: mempty
, ngramsValidPatch: mempty
, ngramsVersion: version
, ngramsVersion: 0
}
initialStateWithVersion :: VersionedNgramsTable -> State
initialStateWithVersion (Versioned { version }) = initialState { ngramsVersion = version }
setTermListSetA :: NgramsTable -> Set NgramsTerm -> TermList -> Action
setTermListSetA ngramsTable ns new_list =
CoreAction $ CommitPatch $ fromNgramsPatches $ PatchMap $ mapWithIndex f $ toMap ns
CoreAction $ CommitPatch $ NgramsTablePatch $ PatchMap $ mapWithIndex f $ toMap ns
where
f :: NgramsTerm -> Unit -> NgramsPatch
f n _unit = NgramsPatch { patch_list, patch_children: mempty }
......@@ -96,31 +124,29 @@ setTermListSetA ngramsTable ns new_list =
type PreConversionRows = Seq.Seq NgramsElement
type TableContainerProps =
( dispatch :: Dispatch
, ngramsChildren :: Map NgramsTerm Boolean
, ngramsParent :: Maybe NgramsTerm
( addCallback :: String -> Effect Unit
, dispatch :: Dispatch
, getNgramsChildren :: NgramsTerm -> Aff (Array NgramsTerm)
, ngramsSelection :: Set NgramsTerm
, ngramsTable :: NgramsTable
, queryExactMatches :: Boolean
, path :: T.Box PageParams
, tabNgramType :: CTabNgramType
, queryExactMatches :: Boolean
, syncResetButton :: Array R.Element
, addCallback :: String -> Effect Unit
, tabNgramType :: CTabNgramType
)
tableContainer :: Record TableContainerProps -> Record TT.TableContainerProps -> R.Element
tableContainer p q = R.createElement (tableContainerCpt p) q []
tableContainerCpt :: Record TableContainerProps -> R.Component TT.TableContainerProps
tableContainerCpt { dispatch
, ngramsChildren
, ngramsParent
tableContainerCpt { addCallback
, dispatch
, getNgramsChildren
, ngramsSelection
, ngramsTable: ngramsTableCache
, path
, queryExactMatches
, tabNgramType
, syncResetButton
, addCallback
, tabNgramType
} = here.component "tableContainer" cpt
where
cpt props _ = do
......@@ -181,7 +207,6 @@ tableContainerCpt { dispatch
]
]
]
, editor
, if (selectionsExist ngramsSelection)
then H.li {className: "list-group-item"} [selectButtons true]
else H.div {} []
......@@ -207,33 +232,6 @@ tableContainerCpt { dispatch
setTermSizeFilter x = T.modify (_ { termSizeFilter = x }) path
setSelection term = dispatch $ setTermListSetA ngramsTableCache ngramsSelection term
editor = H.div {} $ maybe [] edit ngramsParent
where
edit ngrams = [ H.p {} [H.text $ "Editing " <> ngramsTermText ngrams]
, NTC.renderNgramsTree { ngramsTable
, ngrams
, ngramsStyle: []
, ngramsClick
, ngramsEdit
}
, H.button { className: "btn btn-primary"
, on: {click: (const $ do
dispatch AddTermChildren)}
} [H.text "Save"]
, H.button { className: "btn btn-primary"
, on: {click: (const $ dispatch $ SetParentResetChildren Nothing)}
} [H.text "Cancel"]
]
where
ngramsTable = ngramsTableCache # at ngrams
<<< _Just
<<< _NgramsRepoElement
<<< _children
%~ applyPatchSet (patchSetFromMap ngramsChildren)
ngramsClick {depth: 1, ngrams: child} = Just $ dispatch $ ToggleChild false child
ngramsClick _ = Nothing
ngramsEdit _ = Nothing
selectionsExist :: Set NgramsTerm -> Boolean
selectionsExist = not <<< Set.isEmpty
......@@ -254,18 +252,19 @@ tableContainerCpt { dispatch
-- NEXT
type CommonProps =
( afterSync :: Unit -> Aff Unit
, boxes :: Boxes
, tabNgramType :: CTabNgramType
, withAutoUpdate :: Boolean -- (?) not used
( afterSync :: Unit -> Aff Unit
, boxes :: Boxes
, tabNgramType :: CTabNgramType
, withAutoUpdate :: Boolean -- (?) not used
)
type PropsNoReload =
( cacheState :: NT.CacheState
, mTotalRows :: Maybe Int
, path :: T.Box PageParams
, state :: T.Box State
, versioned :: VersionedNgramsTable
( cacheState :: NT.CacheState
, mTotalRows :: Maybe Int
, path :: T.Box PageParams
, state :: T.Box State
, treeEdit :: Record NgramsTreeEditProps
, versioned :: VersionedNgramsTable
| CommonProps
)
......@@ -286,7 +285,7 @@ loadedNgramsTableHeaderCpt = here.component "loadedNgramsTableHeader" cpt where
[ H.h4 { style: { textAlign : "center" } }
[ H.span { className: "fa fa-hand-o-down" } []
, H.text "Extracted Terms" ]
, NTC.searchInput { key: "search-input"
, NTS.searchInput { key: "search-input"
, searchQuery }
]
......@@ -302,14 +301,17 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where
, path
, state
, tabNgramType
, treeEdit: treeEdit@{ getNgramsChildren }
, versioned: Versioned { data: initTable }
} _ = do
state'@{ ngramsChildren, ngramsLocalPatch, ngramsParent, ngramsSelection } <- T.useLive T.unequal state
treeEdit'@{ ngramsParent } <- T.useLive T.unequal treeEdit.box
state'@{ ngramsLocalPatch, ngramsSelection } <- T.useLive T.unequal state
path'@{ scoreType, termListFilter, termSizeFilter } <- T.useLive T.unequal path
params <- T.useFocused (_.params) (\a b -> b { params = a }) path
params'@{ orderBy } <- T.useLive T.unequal params
searchQueryFocused <- T.useFocused (_.searchQuery) (\a b -> b { searchQuery = a }) path
searchQuery <- T.useLive T.unequal searchQueryFocused
isEditing <- T.useFocused (_.isEditing) (\a b -> b { isEditing = a}) treeEdit.box
let ngramsTable = applyNgramsPatches state' initTable
rowMap (Tuple ng nre) =
......@@ -340,7 +342,8 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where
, rootsWithMatches
, state: state'
, termListFilter
, termSizeFilter } then
, termSizeFilter
, treeEdit: treeEdit' } then
Just ngramsElement
else
Nothing
......@@ -348,7 +351,7 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where
performAction = mkDispatch { filteredRows
, path: path'
, state
, state' }
, treeEdit }
-- filteredRows :: PreConversionRows
-- no need to filter offset if cache is off
......@@ -357,13 +360,14 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where
filteredConvertedRows = convertRow <$> filteredRows
convertRow ngramsElement =
{ row: NTC.renderNgramsItem { dispatch: performAction
, ngrams: ngramsElement ^. _NgramsElement <<< _ngrams
, ngramsElement
, ngramsLocalPatch
, ngramsParent
, ngramsSelection
, ngramsTable } []
{ row: renderNgramsItem { dispatch: performAction
, getNgramsChildren
, isEditing
, ngrams: ngramsElement ^. _NgramsElement <<< _ngrams
, ngramsElement
, ngramsLocalPatch
, ngramsSelection
, ngramsTable } []
, delete: false
}
......@@ -409,20 +413,26 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where
<<< _Just
) =<< ngramsParent
R.useEffect' $ do
R.setRef treeEdit.onCancelRef $ Just $ const $ performAction ClearTreeEdit
R.setRef treeEdit.onSaveRef $ Just $ const $ performAction AddTermChildren
let ngramsClick { depth: 1, ngrams: child } = Just $ performAction $ ToggleChild false child
ngramsClick _ = Nothing
R.setRef treeEdit.onNgramsClickRef $ Just ngramsClick
pure $ R.fragment
[ TT.table
{ colNames
, container: tableContainer
{ dispatch: performAction
, ngramsChildren
, ngramsParent
{ addCallback
, dispatch: performAction
, getNgramsChildren
, ngramsSelection
, ngramsTable
, path
, queryExactMatches: exactMatches
, syncResetButton: [ syncResetButton ]
, tabNgramType
, addCallback
}
, params
, rows: filteredConvertedRows
......@@ -445,7 +455,7 @@ ngramsTableOrderWith orderBy =
_ -> identity -- the server ordering is enough here
-- This is used to *decorate* the Select header with the checkbox.
wrapColElts scProps _ (TT.ColumnName "Select") = const [NTC.selectionCheckbox scProps]
wrapColElts scProps _ (TT.ColumnName "Select") = const [NTSC.selectionCheckbox scProps]
wrapColElts _ scoreType (TT.ColumnName "Score") = (_ <> [H.text ("(" <> show scoreType <> ")")])
wrapColElts _ _ _ = identity
......@@ -453,60 +463,57 @@ type MkDispatchProps = (
filteredRows :: PreConversionRows
, path :: PageParams
, state :: T.Box State
, state' :: State
, treeEdit :: Record NgramsTreeEditProps
)
mkDispatch :: Record MkDispatchProps -> (Action -> Effect Unit)
mkDispatch { filteredRows
, path
, state
, state': { ngramsChildren
, ngramsParent
, ngramsSelection } } = performAction
, treeEdit } = performAction
where
allNgramsSelected = allNgramsSelectedOnFirstPage ngramsSelection filteredRows
setParentResetChildren :: Maybe NgramsTerm -> State -> State
setParentResetChildren p = _ { ngramsParent = p, ngramsChildren = Map.empty }
performAction :: Action -> Effect Unit
performAction (SetParentResetChildren p) =
T.modify_ (setParentResetChildren p) state
performAction (ToggleChild b c) =
T.modify_ (\s@{ ngramsChildren: nc } -> s { ngramsChildren = newNC nc }) state
performAction ClearTreeEdit = do
T.write_ initialTreeEdit treeEdit.box
performAction (SetParentResetChildren ngramsParent ngramsChildren) = do
T.write_ { isEditing: true
, ngramsChildren
, ngramsChildrenDiff: Map.empty
, ngramsParent } treeEdit.box
performAction (ToggleChild b c) = do
T.modify_ (\g@{ ngramsChildrenDiff: ncd } -> g { ngramsChildrenDiff = newNC ncd }) treeEdit.box
where
newNC nc = Map.alter (maybe (Just b) (const Nothing)) c nc
newNC ncd = Map.alter (maybe (Just b) (const Nothing)) c ncd
performAction (ToggleSelect c) =
T.modify_ (\s@{ ngramsSelection: ns } -> s { ngramsSelection = toggleSet c ns }) state
performAction ToggleSelectAll =
T.modify_ toggler state
performAction ToggleSelectAll = do
{ ngramsSelection } <- T.read state
T.modify_ (toggler ngramsSelection) state
where
toggler s =
if allNgramsSelected then
toggler ngramsSelection s =
if allNgramsSelectedOnFirstPage ngramsSelection filteredRows then
s { ngramsSelection = Set.empty :: Set NgramsTerm }
else
s { ngramsSelection = selectNgramsOnFirstPage filteredRows }
performAction AddTermChildren = do
{ ngramsChildren, ngramsChildrenDiff, ngramsParent } <- T.read treeEdit.box
case ngramsParent of
Nothing ->
-- impossible but harmless
pure unit
Just parent -> do
here.log2 "[performAction] AddTermChildren, parent" parent
here.log2 "[performAction] AddTermChildren, ngramsChildren" ngramsChildren
let pc = patchSetFromMap ngramsChildren
let pc = patchSetFromMap ngramsChildrenDiff
pe = NgramsPatch { patch_list: mempty, patch_children: pc }
pt = singletonNgramsTablePatch parent pe
T.modify_ (setParentResetChildren Nothing) state
here.log2 "[performAction] pt" pt
let ppt = case (A.head $ Set.toUnfoldable $ Map.keys ngramsChildren) of
Nothing -> mempty
Just h ->
let pp = NgramsPatch { patch_list: mempty
, patch_children: patchSetFromMap $ Map.mapMaybe (\v -> Just $ not v) ngramsChildren }
in
singletonNgramsTablePatch h pp
here.log2 "[performAction] pt with patchSetFromMap" $ pt <> ppt
performAction ClearTreeEdit
-- let ppt = case (A.head $ Set.toUnfoldable $ Map.keys ngramsChildrenDiff) of
-- Nothing -> mempty
-- Just h ->
-- let pp = NgramsPatch { patch_list: mempty
-- , patch_children: patchSetFromMap $ Map.mapMaybe (\v -> Just $ not v) ngramsChildrenDiff }
-- in
-- singletonNgramsTablePatch h pp
-- here.log2 "[performAction] pt with patchSetFromMap" $ pt <> ppt
commitPatch (pt {-<> ppt-}) state
performAction (CoreAction a) = coreDispatch path state a
......@@ -516,15 +523,17 @@ displayRow :: { ngramsElement :: NgramsElement
, rootsWithMatches :: Set NgramsTerm
, state :: State
, termListFilter :: Maybe TermList
, termSizeFilter :: Maybe TermSize } -> Boolean
, termSizeFilter :: Maybe TermSize
, treeEdit :: TreeEdit } -> Boolean
displayRow { ngramsElement: NgramsElement {ngrams, root, list}
, ngramsParentRoot
, state: { ngramsChildren
, ngramsLocalPatch
, ngramsParent }
, state: { ngramsLocalPatch }
, rootsWithMatches
, termListFilter
, termSizeFilter } =
, termSizeFilter
, treeEdit: { ngramsChildren
, ngramsChildrenDiff
, ngramsParent } } =
-- See these issues about the evolution of this filtering.
-- * https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/340
-- * https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/87
......@@ -534,7 +543,7 @@ displayRow { ngramsElement: NgramsElement {ngrams, root, list}
-- ^ and which matches the search query.
&& maybe true (_ == list) termListFilter
-- ^ and which matches the ListType filter.
&& ngramsChildren ^. at ngrams /= Just true
&& ngramsChildrenDiff ^. at ngrams /= Just true
-- ^ and which are not scheduled to be added already
&& Just ngrams /= ngramsParent
-- ^ and which are not our new parent
......@@ -542,9 +551,9 @@ displayRow { ngramsElement: NgramsElement {ngrams, root, list}
-- ^ and which are not the root of our new parent
&& filterTermSize termSizeFilter ngrams
-- ^ and which satisfies the chosen term size
|| ngramsChildren ^. at ngrams == Just false
|| ngramsChildrenDiff ^. at ngrams == Just false
-- ^ unless they are scheduled to be removed.
|| NTC.tablePatchHasNgrams ngramsLocalPatch ngrams
|| tablePatchHasNgrams ngramsLocalPatch ngrams
-- ^ unless they are being processed at the moment.
allNgramsSelectedOnFirstPage :: Set NgramsTerm -> PreConversionRows -> Boolean
......@@ -561,17 +570,51 @@ type MainNgramsTableProps = (
, path :: T.Box PageParams
, session :: Session
, tabType :: TabType
, treeEdit :: Record NgramsTreeEditProps
| CommonProps
)
getNgramsChildrenAff :: Session -> NodeID -> Array ListId -> TabType -> NgramsTerm -> Aff (Array NgramsTerm)
getNgramsChildrenAff session nodeId listIds tabType (NormNgramsTerm ngrams) = do
res :: Either RESTError ({ data :: Array { children :: Array String, ngrams :: String }}) <- get session $ R.GetNgrams params (Just nodeId)
case res of
Left err -> pure []
Right { data: lst } -> case A.uncons (A.filter (\d -> d.ngrams == ngrams) lst) of
Nothing -> pure []
Just { head } -> pure $ NormNgramsTerm <$> head.children
where
params = { limit: 10
, listIds
, offset: Nothing
, orderBy: Nothing
, searchQuery: ngrams
, tabType
, termListFilter: Nothing
, termSizeFilter: Nothing }
mainNgramsTable :: R2.Component MainNgramsTableProps
mainNgramsTable = R.createElement mainNgramsTableCpt
mainNgramsTableCpt :: R.Component MainNgramsTableProps
mainNgramsTableCpt = here.component "mainNgramsTable" cpt
where
cpt props@{ cacheState, path } _ = do
cpt props@{ cacheState, path, session, tabType, treeEdit } _ = do
searchQuery <- T.useFocused (_.searchQuery) (\a b -> b { searchQuery = a }) path
cacheState' <- T.useLive T.unequal cacheState
onCancelRef <- R.useRef Nothing
onNgramsClickRef <- R.useRef Nothing
onSaveRef <- R.useRef Nothing
state <- T.useBox initialState
ngramsLocalPatch <- T.useFocused (_.ngramsLocalPatch) (\a b -> b { ngramsLocalPatch = a }) state
nodeId <- T.useFocused (_.nodeId) (\a b -> b { nodeId = a }) path
nodeId' <- T.useLive T.unequal nodeId
-- let treeEdit = { box: treeEditBox
-- , getNgramsChildren: getNgramsChildrenAff session nodeId' tabType
-- , onCancelRef
-- , onNgramsClickRef
-- , onSaveRef
-- }
-- let path = initialPageParams session nodeId [defaultListId] tabType
......@@ -579,26 +622,120 @@ mainNgramsTableCpt = here.component "mainNgramsTable" cpt
NT.CacheOn -> pure $ R.fragment
[
loadedNgramsTableHeader { searchQuery } []
,
mainNgramsTableCacheOn props []
, mainNgramsTableCacheOn (Record.merge props { state }) []
]
NT.CacheOff -> pure $ R.fragment
[
loadedNgramsTableHeader { searchQuery } []
,
mainNgramsTableCacheOff props []
, ngramsTreeEdit (treeEdit) []
, mainNgramsTableCacheOff (Record.merge props { state }) []
]
type NgramsTreeEditProps =
( box :: T.Box TreeEdit
, getNgramsChildren :: NgramsTerm -> Aff (Array NgramsTerm)
--, ngramsLocalPatch :: T.Box NgramsTablePatch
, onCancelRef :: NgramsActionRef
, onNgramsClickRef :: R.Ref (Maybe NgramsClick)
, onSaveRef :: NgramsActionRef
)
mainNgramsTableCacheOn :: R2.Component MainNgramsTableProps
ngramsTreeEdit :: R2.Component NgramsTreeEditProps
ngramsTreeEdit = R.createElement ngramsTreeEditCpt
ngramsTreeEditCpt :: R.Component NgramsTreeEditProps
ngramsTreeEditCpt = here.component "ngramsTreeEdit" cpt where
cpt props@{ box } _ = do
isEditingFocused <- T.useFocused (_.isEditing) (\a b -> b { isEditing = a }) box
isEditingFocused' <- T.useLive T.unequal isEditingFocused
ngramsParentFocused <- T.useFocused (_.ngramsParent) (\a b -> b { ngramsParent = a}) box
ngramsParentFocused' <- T.useLive T.unequal ngramsParentFocused
pure $ if isEditingFocused'
then case ngramsParentFocused' of
Nothing -> H.div {} []
Just ngramsParent' -> ngramsTreeEditReal (Record.merge props { ngramsParent' }) []
else H.div {} []
type NgramsTreeEditRealProps =
( ngramsParent' :: NgramsTerm
| NgramsTreeEditProps )
ngramsTreeEditReal :: R2.Component NgramsTreeEditRealProps
ngramsTreeEditReal = R.createElement ngramsTreeEditRealCpt
ngramsTreeEditRealCpt :: R.Component NgramsTreeEditRealProps
ngramsTreeEditRealCpt = here.component "ngramsTreeEditReal" cpt where
cpt { box
, getNgramsChildren
, ngramsParent'
, onCancelRef
, onNgramsClickRef
, onSaveRef } _ = do
{ ngramsChildren, ngramsChildrenDiff } <- T.useLive T.unequal box
let ngramsDepth = { depth: 0, ngrams: ngramsParent' }
ngramsChildrenPatched :: Set NgramsTerm
ngramsChildrenPatched = applyPatchSet (patchSetFromMap ngramsChildrenDiff) $ Set.fromFoldable ngramsChildren
-- A patched version of getNgramsChildren. This is used
-- because we're editing the tree and so won't fetch the API
-- ngrams children.
gnc ngrams = if ngrams == ngramsParent'
then do
pure $ A.fromFoldable ngramsChildrenPatched
else do
pure []
pure $ H.div {}
[ H.p {}
[ H.text $ "Editing " <> ngramsTermText ngramsDepth.ngrams ]
, renderNgramsTree { getNgramsChildren: gnc
, ngramsClick
, ngramsDepth
, ngramsEdit
, ngramsStyle: []
, key: show ngramsParent'
<> "-" <> show ngramsChildren
<> "-" <> show ngramsChildrenDiff
}
, H.button { className: "btn btn-primary"
, on: { click: onSaveClick } --(const $ dispatch AddTermChildren)}
} [ H.text "Save" ]
, H.button { className: "btn btn-primary"
, on: { click: onCancelClick } --(const $ dispatch ClearTreeEdit)}
} [ H.text "Cancel" ]
]
where
--ngramsClick {depth: 1, ngrams: child} = Just $ dispatch $ ToggleChild false child
--ngramsClick _ = Nothing
ngramsClick :: NgramsClick
ngramsClick nd = case R.readRef onNgramsClickRef of
Nothing -> Nothing
Just ngc -> ngc nd
ngramsEdit :: NgramsClick
ngramsEdit _ = Nothing
onCancelClick :: forall e. e -> Effect Unit
onCancelClick _ = case R.readRef onCancelRef of
Nothing -> pure unit
Just onCancel -> onCancel unit
onSaveClick :: forall e. e -> Effect Unit
onSaveClick _ = case R.readRef onSaveRef of
Nothing -> pure unit
Just onSave -> onSave unit
type MainNgramsTableCacheProps =
( state :: T.Box State
| MainNgramsTableProps )
mainNgramsTableCacheOn :: R2.Component MainNgramsTableCacheProps
mainNgramsTableCacheOn = R.createElement mainNgramsTableCacheOnCpt
mainNgramsTableCacheOnCpt :: R.Component MainNgramsTableProps
mainNgramsTableCacheOnCpt :: R.Component MainNgramsTableCacheProps
mainNgramsTableCacheOnCpt = here.component "mainNgramsTableCacheOn" cpt where
cpt { afterSync
, boxes
, defaultListId
, path
, state
, tabNgramType
, treeEdit
, withAutoUpdate } _ = do
-- let path = initialPageParams session nodeId [defaultListId] tabType
......@@ -608,7 +745,9 @@ mainNgramsTableCacheOnCpt = here.component "mainNgramsTableCacheOn" cpt where
, boxes
, cacheState: NT.CacheOn
, path
, state
, tabNgramType
, treeEdit
, versioned
, withAutoUpdate } []
useLoaderWithCacheAPI {
......@@ -633,20 +772,24 @@ mainNgramsTableCacheOnCpt = here.component "mainNgramsTableCacheOn" cpt where
handleResponse :: VersionedNgramsTable -> VersionedNgramsTable
handleResponse v = v
mainNgramsTableCacheOff :: R2.Component MainNgramsTableProps
mainNgramsTableCacheOff :: R2.Component MainNgramsTableCacheProps
mainNgramsTableCacheOff = R.createElement mainNgramsTableCacheOffCpt
mainNgramsTableCacheOffCpt :: R.Component MainNgramsTableProps
mainNgramsTableCacheOffCpt :: R.Component MainNgramsTableCacheProps
mainNgramsTableCacheOffCpt = here.component "mainNgramsTableCacheOff" cpt where
cpt { afterSync
, boxes
, path
, state
, tabNgramType
, treeEdit
, withAutoUpdate } _ = do
let render versionedWithCount = mainNgramsTablePaintNoCache { afterSync
, boxes
, cacheState: NT.CacheOff
, path
, state
, tabNgramType
, treeEdit
, versionedWithCount
, withAutoUpdate } []
useLoaderBox { errorHandler
......@@ -681,9 +824,11 @@ mainNgramsTableCacheOffCpt = here.component "mainNgramsTableCacheOff" cpt where
type MainNgramsTablePaintProps = (
cacheState :: NT.CacheState
, path :: T.Box PageParams
, versioned :: VersionedNgramsTable
cacheState :: NT.CacheState
, path :: T.Box PageParams
, state :: T.Box State
, treeEdit :: Record NgramsTreeEditProps
, versioned :: VersionedNgramsTable
| CommonProps
)
......@@ -696,13 +841,16 @@ mainNgramsTablePaintCpt = here.component "mainNgramsTablePaint" cpt
, boxes
, cacheState
, path
, state
, tabNgramType
, treeEdit
, versioned
, withAutoUpdate } _ = do
state <- T.useBox $ initialState versioned
R.useEffectOnce' $ do
let (Versioned { version }) = versioned
T.modify_ (_ { ngramsVersion = version }) state
pure $
loadedNgramsTableBody
{ afterSync
, boxes
......@@ -711,6 +859,7 @@ mainNgramsTablePaintCpt = here.component "mainNgramsTablePaint" cpt
, path
, state
, tabNgramType
, treeEdit
, versioned
, withAutoUpdate
} []
......@@ -718,6 +867,8 @@ mainNgramsTablePaintCpt = here.component "mainNgramsTablePaint" cpt
type MainNgramsTablePaintNoCacheProps = (
cacheState :: NT.CacheState
, path :: T.Box PageParams
, state :: T.Box State
, treeEdit :: Record NgramsTreeEditProps
, versionedWithCount :: VersionedWithCountNgramsTable
| CommonProps
)
......@@ -731,16 +882,19 @@ mainNgramsTablePaintNoCacheCpt = here.component "mainNgramsTablePaintNoCache" cp
, boxes
, cacheState
, path
, state
, tabNgramType
, treeEdit
, versionedWithCount
, withAutoUpdate } _ = do
-- TODO This is lame, make versionedWithCount a proper box?
let count /\ versioned = toVersioned versionedWithCount
state <- T.useBox $ initialState versioned
R.useEffectOnce' $ do
let (Versioned { version }) = versioned
T.modify_ (_ { ngramsVersion = version }) state
pure $
loadedNgramsTableBody
{ afterSync
, boxes
......@@ -749,6 +903,7 @@ mainNgramsTablePaintNoCacheCpt = here.component "mainNgramsTablePaintNoCache" cp
, path
, state
, tabNgramType
, treeEdit
, versioned
, withAutoUpdate } []
......
src/Gargantext/Components/NgramsTable/AutoSync.purs 0 → 100644
View file @ a90287bf
module Gargantext.Components.NgramsTable.AutoSync where
import Data.Maybe (Maybe(..))
import Effect.Class (liftEffect)
import Gargantext.Core.NgramsTable.Types (CoreAction(..), CoreDispatch, CoreState)
import Gargantext.Prelude
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Toestand as T
------------------------------------------------------------------
here :: R2.Here
here = R2.here "Gargantext.Components.NgramsTable.AutoSync"
type AutoSyncInput s =
( state :: T.Box (CoreState s)
, action :: CoreDispatch
)
type AutoSyncOutput =
-- @XXX: cannot use an Either here due to the mecanism of `syncPatches` only
-- returning an `Aff Unit`
-- ( result :: T.Box (Maybe (Either RESTError Unit))
( result :: T.Box (Maybe Unit)
, onPending :: T.Box Boolean
)
useAutoSync :: forall s.
Record (AutoSyncInput s)
-> R.Hooks (Record AutoSyncOutput)
useAutoSync { state, action } = do
-- States
onPending <- T.useBox false
result <- T.useBox Nothing
ngramsLocalPatch <-
T.useFocused
(_.ngramsLocalPatch)
(\a b -> b { ngramsLocalPatch = a }) state
-- Computed
let
exec { new } =
let hasChanges = new /= mempty
in when hasChanges do
T.write_ true onPending
T.write_ Nothing result
action $ Synchronize
{ afterSync: onSuccess
}
onSuccess _ = liftEffect do
T.write_ false onPending
T.write_ (Just unit) result
-- Hooks
R.useEffectOnce' $ T.listen exec ngramsLocalPatch
-- Output
pure
{ onPending
, result
}
src/Gargantext/Components/NgramsTable/Loader.purs
View file @ a90287bf
......@@ -10,8 +10,8 @@ import Effect.Aff (Aff, launchAff_, throwError)
import Effect.Class (liftEffect)
import Effect.Exception (error)
import Gargantext.Components.LoadingSpinner (loadingSpinner)
import Gargantext.Components.NgramsTable.Core (Version, Versioned(..))
import Gargantext.Config.REST (RESTError(..), AffRESTError)
import Gargantext.Core.NgramsTable.Types (Version, Versioned(..))
import Gargantext.Utils.CacheAPI as GUC
import Reactix as R
import Simple.JSON as JSON
......
src/Gargantext/Components/NgramsTable/Search.purs 0 → 100644
View file @ a90287bf
module Gargantext.Components.NgramsTable.Search where
import Data.Nullable (Nullable, null)
import DOM.Simple as DOM
import Gargantext.Prelude
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Reactix.DOM.HTML as H
import Toestand as T
here :: R2.Here
here = R2.here "Gargantext.Components.NgramsTable.Search"
type SearchInputProps =
( searchQuery :: T.Box String
)
-- "key": to prevent refreshing & losing input
searchInput :: R2.Leaf ( key :: String | SearchInputProps )
searchInput = R2.leafComponent searchInputCpt
searchInputCpt :: R.Component ( key :: String | SearchInputProps )
searchInputCpt = here.component "searchInput" cpt
where
cpt { searchQuery } _ = do
inputRef <- R.useRef null
pure $ R2.row
[ H.div { className: "col-12" }
[ H.div { className: "input-group" }
[ searchButton { inputRef, searchQuery } []
, searchFieldInput { inputRef, searchQuery } []
]
]
]
type SearchButtonProps =
( inputRef :: R.Ref (Nullable DOM.Element)
, searchQuery :: T.Box String
)
searchButton :: R2.Component SearchButtonProps
searchButton = R.createElement searchButtonCpt
searchButtonCpt :: R.Component SearchButtonProps
searchButtonCpt = here.component "searchButton" cpt where
cpt { inputRef, searchQuery } _ = do
searchQuery' <- T.useLive T.unequal searchQuery
pure $ H.div { className: "input-group-prepend" }
[ if searchQuery' /= ""
then
H.button { className: "btn btn-danger"
, on: { click: \_ -> R2.setInputValue inputRef "" } }
-- T.write "" searchQuery } }
[ H.span {className: "fa fa-times"} []]
else H.span { className: "fa fa-search input-group-text" } []
]
type SearchFieldInputProps =
( inputRef :: R.Ref (Nullable DOM.Element)
, searchQuery :: T.Box String
)
searchFieldInput :: R2.Component SearchFieldInputProps
searchFieldInput = R.createElement searchFieldInputCpt
searchFieldInputCpt :: R.Component SearchFieldInputProps
searchFieldInputCpt = here.component "searchFieldInput" cpt where
cpt { inputRef, searchQuery } _ = do
-- searchQuery' <- T.useLive T.unequal searchQuery
pure $ H.input { className: "form-control"
-- , defaultValue: searchQuery'
, name: "search"
, on: { input: \e -> T.write (R.unsafeEventValue e) searchQuery }
, placeholder: "Search"
, ref: inputRef
, type: "value"
}
src/Gargantext/Components/NgramsTable/SelectionCheckbox.purs 0 → 100644
View file @ a90287bf
module Gargantext.Components.NgramsTable.SelectionCheckbox where
import Data.Maybe (Maybe(..))
import Data.Nullable (null, toMaybe)
import Data.Set (Set)
import Data.Set as Set
import FFI.Simple (delay)
import Gargantext.Core.NgramsTable.Types (Action(..), Dispatch, NgramsTerm)
import Gargantext.Prelude
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Reactix.DOM.HTML as H
here :: R2.Here
here = R2.here "Gargantext.Components.NgramsTable.SelectionCheckbox"
type SelectionCheckboxProps =
( allNgramsSelected :: Boolean
, dispatch :: Dispatch
, ngramsSelection :: Set NgramsTerm
)
selectionCheckbox :: Record SelectionCheckboxProps -> R.Element
selectionCheckbox props = R.createElement selectionCheckboxCpt props []
selectionCheckboxCpt :: R.Component SelectionCheckboxProps
selectionCheckboxCpt = here.component "selectionCheckbox" cpt
where
cpt { allNgramsSelected, dispatch, ngramsSelection } _ = do
ref <- R.useRef null
R.useEffect' $ delay unit $ \_ -> do
let mCb = toMaybe $ R.readRef ref
case mCb of
Nothing -> pure unit
Just cb -> do
_ <- if allNgramsSelected || (Set.isEmpty ngramsSelection) then
R2.setIndeterminateCheckbox cb false
else
R2.setIndeterminateCheckbox cb true
pure unit
pure $ H.input { checked: allNgramsSelected
, className: "checkbox"
, on: { change: const $ dispatch $ ToggleSelectAll }
, ref
, type: "checkbox" }
src/Gargantext/Components/NgramsTable/SyncResetButton.purs 0 → 100644
View file @ a90287bf
module Gargantext.Components.NgramsTable.SyncResetButton where
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import FFI.Simple.Functions (delay)
import Gargantext.Core.NgramsTable.Types (CoreAction(..), CoreDispatch, NgramsTablePatch)
import Gargantext.Prelude
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Reactix.DOM.HTML as H
import Toestand as T
here :: R2.Here
here = R2.here "Gargantext.Components.NgramsTable.SyncResetButton"
-- | 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" ]
]
]
src/Gargantext/Components/NgramsTable/Components.purs → src/Gargantext/Components/NgramsTable/Tree.purs
View file @ a90287bf
module Gargantext.Components.NgramsTable.Components where
module Gargantext.Components.NgramsTable.Tree where
import Data.Array as A
import Data.Either (Either(..))
import Data.Lens ((^..), (^.), view)
import Data.Lens.At (at)
import Data.Lens.Fold (folded)
import Data.Lens.Index (ix)
import Data.List (null, toUnfoldable) as L
import Data.List (List)
import Data.List as L
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Nullable (null, toMaybe)
import Data.Nullable (Nullable, null, toMaybe)
import Data.Set (Set)
import Data.Set as Set
import DOM.Simple as DOM
import Effect (Effect)
import FFI.Simple (delay)
import Gargantext.Components.NgramsTable.Core (Action(..), Dispatch, NgramsElement, NgramsTable, NgramsTablePatch, NgramsTerm, _NgramsElement, _NgramsRepoElement, _PatchMap, _children, _list, _ngrams, _occurrences, ngramsTermText, replace, setTermListA)
import Effect.Aff (Aff, launchAff_)
import Effect.Class (liftEffect)
import Gargantext.Core.NgramsTable.Functions (applyNgramsPatches, setTermListA, tablePatchHasNgrams)
import Gargantext.Core.NgramsTable.Types (Action(..), NgramsClick, NgramsDepth, NgramsElement, NgramsTable, NgramsTablePatch(..), NgramsTerm, _NgramsElement, _NgramsRepoElement, _PatchMap, _children, _list, _ngrams, _occurrences, ngramsTermText, replace)
import Gargantext.Components.Table as Tbl
import Gargantext.Prelude (Unit, bind, const, discard, map, not, otherwise, pure, show, unit, ($), (+), (/=), (<<<), (<>), (==), (>), (||))
import Gargantext.Config.REST (logRESTError)
import Gargantext.Hooks.Loader (useLoader)
import Gargantext.Prelude (Unit, bind, const, discard, map, mempty, not, otherwise, pure, show, unit, ($), (+), (/=), (<<<), (<>), (==), (>), (||))
import Gargantext.Types as GT
import Gargantext.Utils.Reactix as R2
import React.DOM (a, span, text)
import React.DOM.Props as DOM
import Reactix as R
import Reactix.DOM.HTML as H
import Record as Record
import Toestand as T
import Type.Proxy (Proxy(..))
here :: R2.Here
here = R2.here "Gargantext.Components.NgramsTable.Components"
type SearchInputProps =
( searchQuery :: T.Box String
)
-- "key": to prevent refreshing & losing input
searchInput :: R2.Leaf ( key :: String | SearchInputProps )
searchInput = R2.leafComponent searchInputCpt
searchInputCpt :: R.Component ( key :: String | SearchInputProps )
searchInputCpt = here.component "searchInput" cpt
where
cpt { searchQuery } _ = do
pure $ R2.row
[ H.div { className: "col-12" }
[ H.div { className: "input-group" }
[ searchButton { searchQuery } []
, searchFieldInput { searchQuery } []
]
]
]
type SearchButtonProps =
( searchQuery :: T.Box String
)
searchButton :: R2.Component SearchButtonProps
searchButton = R.createElement searchButtonCpt
searchButtonCpt :: R.Component SearchButtonProps
searchButtonCpt = here.component "searchButton" cpt where
cpt { searchQuery } _ = do
searchQuery' <- T.useLive T.unequal searchQuery
pure $ H.div { className: "input-group-prepend" }
[ if searchQuery' /= ""
then
H.button { className: "btn btn-danger"
, on: {click: \_ -> T.write "" searchQuery}}
[ H.span {className: "fa fa-times"} []]
else H.span { className: "fa fa-search input-group-text" } []
]
type SearchFieldInputProps =
( searchQuery :: T.Box String
)
searchFieldInput :: R2.Component SearchFieldInputProps
searchFieldInput = R.createElement searchFieldInputCpt
searchFieldInputCpt :: R.Component SearchFieldInputProps
searchFieldInputCpt = here.component "searchFieldInput" cpt where
cpt { searchQuery } _ = do
-- searchQuery' <- T.useLive T.unequal searchQuery
pure $ H.input { className: "form-control"
-- , defaultValue: searchQuery'
, name: "search"
, on: { input: \e -> T.write (R.unsafeEventValue e) searchQuery }
, placeholder: "Search"
, type: "value"
}
type SelectionCheckboxProps =
( allNgramsSelected :: Boolean
, dispatch :: Dispatch
, ngramsSelection :: Set NgramsTerm
)
selectionCheckbox :: Record SelectionCheckboxProps -> R.Element
selectionCheckbox props = R.createElement selectionCheckboxCpt props []
selectionCheckboxCpt :: R.Component SelectionCheckboxProps
selectionCheckboxCpt = here.component "selectionCheckbox" cpt
where
cpt { allNgramsSelected, dispatch, ngramsSelection } _ = do
ref <- R.useRef null
R.useEffect' $ delay unit $ \_ -> do
let mCb = toMaybe $ R.readRef ref
case mCb of
Nothing -> pure unit
Just cb -> do
_ <- if allNgramsSelected || (Set.isEmpty ngramsSelection) then
R2.setIndeterminateCheckbox cb false
else
R2.setIndeterminateCheckbox cb true
pure unit
pure $ H.input { checked: allNgramsSelected
, className: "checkbox"
, on: { change: const $ dispatch $ ToggleSelectAll }
, ref
, type: "checkbox" }
here = R2.here "Gargantext.Components.NgramsTable.Tree"
type RenderNgramsTree =
( ngrams :: NgramsTerm
, ngramsClick :: NgramsClick
, ngramsEdit :: NgramsClick
, ngramsStyle :: Array DOM.Props
, ngramsTable :: NgramsTable
( getNgramsChildren :: NgramsTerm -> Aff (Array NgramsTerm)
--, ngramsChildren :: List NgramsTerm
, ngramsClick :: NgramsClick
, ngramsDepth :: NgramsDepth
, ngramsEdit :: NgramsClick
, ngramsStyle :: Array DOM.Props
--, ngramsTable :: NgramsTable
, key :: String -- used to refresh the tree on diff change
)
renderNgramsTree :: Record RenderNgramsTree -> R.Element
renderNgramsTree p = R.createElement renderNgramsTreeCpt p []
renderNgramsTreeCpt :: R.Component RenderNgramsTree
renderNgramsTreeCpt = here.component "renderNgramsTree" cpt
where
cpt { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit} _ =
pure $ H.ul {} [
H.span { className: "tree" } [
H.span { className: "righthanded" } [
tree { ngramsClick
, ngramsDepth: {ngrams, depth: 0}
, ngramsEdit
, ngramsStyle
, ngramsTable
}
cpt { getNgramsChildren, ngramsClick, ngramsDepth, ngramsEdit, ngramsStyle } _ = do
pure $ H.ul {}
[ H.span { className: "tree" }
[ H.span { className: "righthanded" }
[ tree { getNgramsChildren
--, ngramsChildren
, ngramsClick
, ngramsDepth
, ngramsEdit
, ngramsStyle
}
]
]
]
]
type NgramsDepth = {ngrams :: NgramsTerm, depth :: Int}
type NgramsClick = NgramsDepth -> Maybe (Effect Unit)
type TagProps =
( ngramsClick :: NgramsClick
, ngramsDepth :: NgramsDepth
......@@ -165,57 +87,77 @@ tag tagProps =
-}
type TreeProps =
( ngramsEdit :: NgramsClick
, ngramsTable :: NgramsTable
( getNgramsChildren :: NgramsTerm -> Aff (Array NgramsTerm)
, ngramsEdit :: NgramsClick
--, ngramsTable :: NgramsTable
| TagProps
)
tree :: Record TreeProps -> R.Element
tree p = R.createElement treeCpt p []
treeCpt :: R.Component TreeProps
treeCpt = here.component "tree" cpt
where
cpt params@{ ngramsClick, ngramsDepth, ngramsEdit, ngramsStyle, ngramsTable } _ =
pure $
H.li { style: {width : "100%"} }
([ H.i { className, style } [] ]
<> [ R2.buff $ tag [ text $ " " <> ngramsTermText ngramsDepth.ngrams ] ]
<> maybe [] edit (ngramsEdit ngramsDepth)
<> [ forest cs ]
)
where
tag =
case ngramsClick ngramsDepth of
Just effect ->
a (ngramsStyle <> [DOM.onClick $ const effect])
Nothing ->
span ngramsStyle
edit effect = [ H.text " "
, H.i { className: "fa fa-pencil"
, on: { click: const effect } } []
]
leaf = L.null cs
className = "fa fa-chevron-" <> if open then "down" else "right"
style = if leaf then {color: "#adb5bd"} else {color: ""}
open = not leaf || false {- TODO -}
cs = ngramsTable ^.. ix ngramsDepth.ngrams <<< _NgramsRepoElement <<< _children <<< folded
-- cs has a list is ok, the length is the number of direct children of an ngram which is generally < 10.
forest =
let depth = ngramsDepth.depth + 1 in
if depth > 10 then
const $ H.text "ERROR DEPTH > 10"
else
H.ul {} <<< map (\ngrams -> tree (params { ngramsDepth = {depth, ngrams} })) <<< L.toUnfoldable
type RenderNgramsItem = (
dispatch :: Action -> Effect Unit
treeCpt = here.component "tree" cpt where
cpt props@{ getNgramsChildren, ngramsDepth } _ = do
let loader p = do
res <- getNgramsChildren p
pure $ Right res
let render nc = treeLoaded (Record.merge props { ngramsChildren: L.fromFoldable nc })
useLoader { errorHandler
, loader
, path: ngramsDepth.ngrams
, render }
where
errorHandler = logRESTError here "[tree]"
type TreeLoaded =
( ngramsChildren :: List NgramsTerm
| TreeProps )
treeLoaded :: Record TreeLoaded -> R.Element
treeLoaded p = R.createElement treeLoadedCpt p []
treeLoadedCpt :: R.Component TreeLoaded
treeLoadedCpt = here.component "treeLoaded" cpt where
cpt params@{ ngramsChildren, ngramsClick, ngramsDepth, ngramsEdit, ngramsStyle } _ = do
pure $
H.li { style: { width : "100%" } }
([ H.i { className, style } [] ]
<> [ R2.buff $ tag [ text $ " " <> ngramsTermText ngramsDepth.ngrams ] ]
<> maybe [] edit (ngramsEdit ngramsDepth)
<> [ forest ngramsChildren ]
)
where
tag =
case ngramsClick ngramsDepth of
Just effect ->
a (ngramsStyle <> [DOM.onClick $ const effect])
Nothing ->
span ngramsStyle
edit effect = [ H.text " "
, H.i { className: "fa fa-pencil"
, on: { click: const effect } } []
]
leaf = L.null ngramsChildren
className = "fa fa-chevron-" <> if open then "down" else "right"
style = if leaf then {color: "#adb5bd"} else {color: ""}
open = not leaf || false {- TODO -}
--cs = ngramsTable ^.. ix ngramsDepth.ngrams <<< _NgramsRepoElement <<< _children <<< folded
-- cs has a list is ok, the length is the number of direct children of an ngram which is generally < 10.
forest =
let depth = ngramsDepth.depth + 1 in
if depth > 10 then
const $ H.text "ERROR DEPTH > 10"
else
H.ul {} <<< map (\ngrams -> tree ((Record.delete (Proxy :: Proxy "ngramsChildren") params) { ngramsDepth = {depth, ngrams} })) <<< L.toUnfoldable
type RenderNgramsItem =
( dispatch :: Action -> Effect Unit
, getNgramsChildren :: NgramsTerm -> Aff (Array NgramsTerm)
, isEditing :: T.Box Boolean
, ngrams :: NgramsTerm
, ngramsElement :: NgramsElement
, ngramsLocalPatch :: NgramsTablePatch
, ngramsParent :: Maybe NgramsTerm
, ngramsSelection :: Set NgramsTerm
, ngramsTable :: NgramsTable
)
......@@ -226,32 +168,41 @@ renderNgramsItemCpt :: R.Component RenderNgramsItem
renderNgramsItemCpt = here.component "renderNgramsItem" cpt
where
cpt { dispatch
--, getNgramsChildren
, isEditing
, ngrams
, ngramsElement
, ngramsLocalPatch
, ngramsParent
, ngramsSelection
, ngramsTable
} _ = do
pure $ Tbl.makeRow [
H.div { className: "ngrams-selector" } [
H.span { className: "ngrams-chooser fa fa-eye-slash"
isEditing' <- T.useLive T.unequal isEditing
pure $ Tbl.makeRow
[ H.div { className: "ngrams-selector" }
[ H.span { className: "ngrams-chooser fa fa-eye-slash"
, on: { click: onClick } } []
]
, selected
, checkbox GT.MapTerm
, checkbox GT.StopTerm
, H.div {} ( if ngramsParent == Nothing
then [renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit }]
else [H.a { on: { click: const $ dispatch $ ToggleChild true ngrams } }
[ H.i { className: "fa fa-plus" } []]
, R2.buff $ tag [ text $ " " <> ngramsTermText ngramsDepth.ngrams ]
]
)
, H.div {}
( if isEditing'
then [ H.a { on: { click: const $ dispatch $ ToggleChild true ngrams } }
[ H.i { className: "fa fa-plus" } [] ]
, R2.buff $ tag [ text $ " " <> ngramsTermText ngramsDepth.ngrams ]
]
else [ renderNgramsTree { getNgramsChildren: getNgramsChildren'
, ngramsClick
, ngramsDepth
, ngramsEdit
, ngramsStyle
, key: "" } ]
)
, H.text $ show (ngramsElement ^. _NgramsElement <<< _occurrences)
]
where
ngramsDepth= {ngrams, depth: 0 }
ngramsDepth = { ngrams, depth: 0 }
tag =
case ngramsClick ngramsDepth of
Just effect ->
......@@ -263,7 +214,14 @@ renderNgramsItemCpt = here.component "renderNgramsItem" cpt
-- R2.callTrigger toggleSidePanel unit
termList = ngramsElement ^. _NgramsElement <<< _list
ngramsStyle = [termStyle termList ngramsOpacity]
ngramsEdit = Just <<< dispatch <<< SetParentResetChildren <<< Just <<< view _ngrams
ngramsEdit { ngrams: n } = Just $ dispatch $ SetParentResetChildren (Just n) (ngramsChildren n)
tbl = applyNgramsPatches { ngramsLocalPatch
, ngramsStagePatch: mempty
, ngramsValidPatch: mempty
, ngramsVersion: 0 } ngramsTable
getNgramsChildren' :: NgramsTerm -> Aff (Array NgramsTerm)
getNgramsChildren' n = pure $ A.fromFoldable $ ngramsChildren n
ngramsChildren n = tbl ^.. ix n <<< _NgramsRepoElement <<< _children <<< folded
ngramsClick =
Just <<< dispatch <<< CoreAction <<< cycleTermListItem <<< view _ngrams
-- ^ This is the old behavior it is nicer to use since one can
......@@ -314,10 +272,6 @@ termStyle GT.CandidateTerm opacity = DOM.style
, opacity
}
tablePatchHasNgrams :: NgramsTablePatch -> NgramsTerm -> Boolean
tablePatchHasNgrams ngramsTablePatch ngrams =
isJust $ ngramsTablePatch.ngramsPatches ^. _PatchMap <<< at ngrams
nextTermList :: GT.TermList -> GT.TermList
nextTermList GT.MapTerm = GT.StopTerm
......
src/Gargantext/Components/Nodes/Annuaire.purs
View file @ a90287bf
......@@ -151,16 +151,15 @@ pageLayoutCpt = here.component "pageLayout" cpt
errorHandler = logRESTError here "[pageLayout]"
type PageProps =
( session :: Session
, frontends :: Frontends
( frontends :: Frontends
, pagePath :: T.Box PagePath
-- , info :: AnnuaireInfo
, session :: Session
, table :: TableResult CT.NodeContact
)
page :: Record PageProps -> R.Element
page props = R.createElement pageCpt props []
pageCpt :: R.Component PageProps
pageCpt = here.component "page" cpt
where
......
src/Gargantext/Components/Nodes/Annuaire/Tabs.purs
View file @ a90287bf
......@@ -12,7 +12,7 @@ import Gargantext.Components.App.Store (Boxes)
import Gargantext.Components.DocsTable as DT
import Gargantext.Components.DocsTable.Types (Year)
import Gargantext.Components.NgramsTable as NT
import Gargantext.Components.NgramsTable.Core as NTC
import Gargantext.Core.NgramsTable.Functions as NTC
import Gargantext.Components.Nodes.Lists.Types as LTypes
import Gargantext.Components.Nodes.Texts.Types as TextsT
import Gargantext.Components.Tab as Tab
......@@ -113,18 +113,29 @@ ngramsViewCpt = here.component "ngramsView" cpt where
NTC.initialPageParams session nodeId
[ defaultListId ] (TabDocument TabDocs)
pure $ NT.mainNgramsTable (props' path) [] where
most = RX.pick props :: Record NTCommon
props' path =
(Record.merge most
{ afterSync
, path
, tabType: TabPairing (TabNgramType $ modeTabType mode)
, tabNgramType: modeTabType' mode
, withAutoUpdate: false }) :: Record NT.MainNgramsTableProps
where
afterSync :: Unit -> Aff Unit
afterSync _ = pure unit
onCancelRef <- R.useRef Nothing
onNgramsClickRef <- R.useRef Nothing
onSaveRef <- R.useRef Nothing
treeEditBox <- T.useBox NT.initialTreeEdit
let most = RX.pick props :: Record NTCommon
props' =
(Record.merge most
{ afterSync
, path
, tabType: TabPairing (TabNgramType $ modeTabType mode)
, tabNgramType: modeTabType' mode
, treeEdit: { box: treeEditBox
, getNgramsChildren: \_ -> pure []
, onCancelRef
, onNgramsClickRef
, onSaveRef }
, withAutoUpdate: false }) :: Record NT.MainNgramsTableProps
afterSync :: Unit -> Aff Unit
afterSync _ = pure unit
pure $ NT.mainNgramsTable props' []
type NTCommon =
( boxes :: Boxes
......
src/Gargantext/Components/Nodes/Annuaire/User/Contacts/Tabs.purs
View file @ a90287bf
......@@ -11,7 +11,7 @@ import Gargantext.Components.App.Store (Boxes)
import Gargantext.Components.DocsTable as DT
import Gargantext.Components.DocsTable.Types (Year)
import Gargantext.Components.NgramsTable as NT
import Gargantext.Components.NgramsTable.Core as NTC
import Gargantext.Core.NgramsTable.Functions as NTC
import Gargantext.Components.Nodes.Lists.Types as LTypes
import Gargantext.Components.Nodes.Texts.Types as TTypes
import Gargantext.Components.Tab as Tab
......@@ -146,6 +146,10 @@ ngramsViewCpt = here.component "ngramsView" cpt
, nodeId
, session } _ = do
path <- T.useBox $ NTC.initialPageParams session nodeId [defaultListId] (TabDocument TabDocs)
onCancelRef <- R.useRef Nothing
onNgramsClickRef <- R.useRef Nothing
onSaveRef <- R.useRef Nothing
treeEditBox <- T.useBox NT.initialTreeEdit
pure $ NT.mainNgramsTable {
afterSync: \_ -> pure unit
......@@ -156,6 +160,11 @@ ngramsViewCpt = here.component "ngramsView" cpt
, session
, tabNgramType
, tabType
, treeEdit: { box: treeEditBox
, getNgramsChildren: \_ -> pure []
, onCancelRef
, onNgramsClickRef
, onSaveRef }
, withAutoUpdate: false
} []
where
......
src/Gargantext/Components/Nodes/Lists/Tabs.purs
View file @ a90287bf
......@@ -8,8 +8,7 @@ import Data.Tuple.Nested ((/\))
import Effect.Class (liftEffect)
import Gargantext.Components.App.Store (Boxes)
import Gargantext.Components.NgramsTable as NT
import Gargantext.Components.NgramsTable.Core (PageParams)
import Gargantext.Components.NgramsTable.Core as NTC
import Gargantext.Core.NgramsTable.Functions as NTC
import Gargantext.Components.Nodes.Corpus.Chart.Metrics (metrics)
import Gargantext.Components.Nodes.Corpus.Chart.Pie (pie, bar)
import Gargantext.Components.Nodes.Corpus.Chart.Tree (tree)
......@@ -17,6 +16,7 @@ import Gargantext.Components.Nodes.Corpus.Chart.Utils (mNgramsTypeFromTabType)
import Gargantext.Components.Nodes.Corpus.Types (CorpusData)
import Gargantext.Components.Tab as Tab
import Gargantext.Components.Table.Types (Params)
import Gargantext.Core.NgramsTable.Types (PageParams)
import Gargantext.Prelude (bind, pure, unit, ($))
import Gargantext.Sessions (Session)
import Gargantext.Types (CTabNgramType(..), Mode(..), TabSubType(..), TabType(..), modeTabType)
......@@ -89,6 +89,10 @@ ngramsViewCpt = here.component "ngramsView" cpt where
, session
, path } _ = do
chartsReload <- T.useBox T2.newReload
onCancelRef <- R.useRef Nothing
onNgramsClickRef <- R.useRef Nothing
onSaveRef <- R.useRef Nothing
treeEditBox <- T.useBox NT.initialTreeEdit
{ listIds, nodeId, params } <- T.useLive T.unequal path
......@@ -96,13 +100,13 @@ ngramsViewCpt = here.component "ngramsView" cpt where
R.fragment
[
ngramsView'
{ mode
, boxes
, session
, params
{ boxes
, corpusData: props.corpusData
, listIds
, mode
, nodeId
, corpusData: props.corpusData
, params
, session
} []
,
NT.mainNgramsTable
......@@ -114,6 +118,11 @@ ngramsViewCpt = here.component "ngramsView" cpt where
, session
, tabNgramType
, tabType
, treeEdit: { box: treeEditBox
, getNgramsChildren: NT.getNgramsChildrenAff session nodeId listIds tabType
, onCancelRef
, onNgramsClickRef
, onSaveRef }
, withAutoUpdate: false
} []
]
......@@ -139,26 +148,28 @@ ngramsViewCpt = here.component "ngramsView" cpt where
-- @XXX re-render issue -> clone component
type NgramsViewProps' =
( mode :: Mode
, boxes :: Boxes
, session :: Session
( boxes :: Boxes
, corpusData :: CorpusData
, listIds :: Array Int
, params :: Params
, mode :: Mode
, nodeId :: Int
, corpusData :: CorpusData
, params :: Params
, session :: Session
)
ngramsView' :: R2.Component NgramsViewProps'
ngramsView' = R.createElement ngramsViewCpt'
ngramsViewCpt' :: R.Memo NgramsViewProps'
ngramsViewCpt' = R.memo' $ here.component "ngramsView_clone" cpt where
cpt { mode
, boxes
, session
--ngramsViewCpt' :: R.Memo NgramsViewProps'
--ngramsViewCpt' = R.memo' $ here.component "ngramsView_clone" cpt where
ngramsViewCpt' :: R.Component NgramsViewProps'
ngramsViewCpt' = here.component "ngramsView_clone" cpt where
cpt { boxes
, corpusData: { defaultListId }
, listIds
, params
, mode
, nodeId
, corpusData: { defaultListId }
, params
, session
} _ = do
let path' = {
......
src/Gargantext/Components/Nodes/Texts.purs
View file @ a90287bf
......@@ -6,7 +6,6 @@ import Data.Generic.Rep (class Generic)
import Data.Maybe (Maybe(..))
import Data.Show.Generic (genericShow)
import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Effect.Aff (launchAff_)
import Gargantext.Components.App.Store (Boxes)
import Gargantext.Components.App.Store as AppStore
......@@ -128,7 +127,7 @@ textsLayoutWithKeyCpt = here.component "textsLayoutWithKey" cpt where
}
where
errorHandler = logRESTError here "[textsLayoutWithKey]"
afterCacheStateChange cacheState = do
afterCacheStateChange _cacheState = do
launchAff_ $ clearCache unit
-- TODO
--sessionUpdate $ setCacheState session nodeId cacheState
......@@ -248,7 +247,7 @@ histoRender = R.createElement histoRenderCpt
histoRenderCpt :: R.Component HistoProps
histoRenderCpt = here.component "histoRender" cpt where
cpt { boxes, path, onClick, onInit, reload, session } _ = do
reload' <- T.useLive T.unequal reload
_ <- T.useLive T.unequal reload
pure $ histo { boxes, path, onClick, onInit, session }
......
src/Gargantext/Components/NgramsTable/Core.purs → src/Gargantext/Core/NgramsTable/Functions.purs
View file @ a90287bf
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
, useAutoSync
)
module Gargantext.Core.NgramsTable.Functions
where
import Gargantext.Prelude
......@@ -85,36 +6,24 @@ import Gargantext.Prelude
import Control.Monad.State (class MonadState, execState)
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.Foldable (foldl)
import Data.Lens (use, view, (^?), (^.), (?=), (%~), (%=), (.~))
import Data.Lens.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)
......@@ -123,155 +32,30 @@ 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 (AffRESTError, RESTError)
import Gargantext.Config.Utils (handleRESTError)
import Gargantext.Core.NgramsTable.Types
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.Types (AsyncTask, AsyncTaskType(..), AsyncTaskWithType(..), CTabNgramType(..), FrontendError, 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)
here = R2.here "Gargantext.Core.NgramsTable.Functions"
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 =
......@@ -290,10 +74,6 @@ initialPageParams session nodeId listIds tabType =
ngramsTermText :: NgramsTerm -> String
ngramsTermText (NormNgramsTerm t) = t
-- TODO
normNgramInternal :: CTabNgramType -> String -> String
normNgramInternal CTabAuthors = identity
......@@ -307,104 +87,6 @@ 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
......@@ -418,57 +100,6 @@ ngramsRepoElementToNgramsElement ngrams occurrences (NgramsRepoElement { childre
}
-----------------------------------------------------------------------------------
{-
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}) =
......@@ -493,9 +124,6 @@ wordBoundaryReg2 = case R.regex ("(" <> wordBoundaryChars <> ")\\1") (R.global <
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
......@@ -558,162 +186,22 @@ highlightNgrams ntype table@(NgramsTable {ngrams_repo_elements: elts}) input0 =
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
--applyNgramsTablePatchToSingleTerm :: NgramsTerm -> NgramsTablePatch -> Set NgramsTerm -> Set NgramsTerm
--applyNgramsTablePatchToSingleTerm ngram patch s =
-- applyNgramsTablePatch patch $
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)
......@@ -744,26 +232,12 @@ applyPatchMap applyPatchValue (PatchMap pm) m =
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
isEmptyNgramsTablePatch (NgramsTablePatch ngramsPatches) = isEmptyPatchMap ngramsPatches
fromNgramsPatches :: NgramsPatches -> NgramsTablePatch
fromNgramsPatches ngramsPatches = {ngramsPatches}
fromNgramsPatches ngramsPatches = NgramsTablePatch ngramsPatches
findNgramRoot :: NgramsTable -> NgramsTerm -> NgramsTerm
findNgramRoot (NgramsTable m) n =
......@@ -782,10 +256,6 @@ 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
......@@ -837,7 +307,7 @@ newElemsTable = mapWithIndex newElem
-}
applyNgramsTablePatch :: NgramsTablePatch -> NgramsTable -> NgramsTable
applyNgramsTablePatch { ngramsPatches } (NgramsTable m) =
applyNgramsTablePatch (NgramsTablePatch ngramsPatches) (NgramsTable m) =
execState (reParentNgramsTablePatch ngramsPatches) $
NgramsTable $ m { ngrams_repo_elements =
applyPatchMap applyNgramsPatch ngramsPatches m.ngrams_repo_elements }
......@@ -846,19 +316,6 @@ 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
......@@ -891,7 +348,7 @@ newNgramPatch list =
addNewNgramP :: NgramsTerm -> TermList -> NgramsTablePatch
addNewNgramP ngrams list =
{ ngramsPatches: singletonPatchMap ngrams (newNgramPatch list) }
NgramsTablePatch $ singletonPatchMap ngrams (newNgramPatch list)
addNewNgramA :: NgramsTerm -> TermList -> CoreAction
addNewNgramA ngrams list = CommitPatch $ addNewNgramP ngrams list
......@@ -910,7 +367,7 @@ putNgramsPatches { listIds, nodeId, session, tabType } = put session putNgrams
syncPatches :: forall p s. CoreParams p -> T.Box (CoreState s) -> (Unit -> Aff Unit) -> Effect Unit
syncPatches props state callback = do
{ ngramsLocalPatch: ngramsLocalPatch@{ ngramsPatches }
{ ngramsLocalPatch: ngramsLocalPatch@(NgramsTablePatch ngramsPatches)
, ngramsStagePatch
, ngramsVersion } <- T.read state
when (isEmptyNgramsTablePatch ngramsStagePatch) $ do
......@@ -987,8 +444,6 @@ loadNgramsTable
-- , termListFilter
-- , termSizeFilter } (Just nodeId)
type NgramsListByTabType = Map TabType VersionedNgramsTable
loadNgramsTableAll :: PageParams -> AffRESTError NgramsListByTabType
loadNgramsTableAll { nodeId, listIds, session } = do
let
......@@ -1013,35 +468,13 @@ 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
T.modify_ (_ { ngramsLocalPatch = mempty :: NgramsTablePatch }) state
isSingleNgramsTerm :: NgramsTerm -> Boolean
isSingleNgramsTerm nt = isSingleTerm $ ngramsTermText nt
......@@ -1058,111 +491,7 @@ 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 AutoSyncInput s =
( state :: T.Box (CoreState s)
, action :: CoreDispatch
)
type AutoSyncOutput =
-- @XXX: cannot use an Either here due to the mecanism of `syncPatches` only
-- returning an `Aff Unit`
-- ( result :: T.Box (Maybe (Either RESTError Unit))
( result :: T.Box (Maybe Unit)
, onPending :: T.Box Boolean
)
useAutoSync :: forall s.
Record (AutoSyncInput s)
-> R.Hooks (Record AutoSyncOutput)
useAutoSync { state, action } = do
-- States
onPending <- T.useBox false
result <- T.useBox Nothing
ngramsLocalPatch <-
T.useFocused
(_.ngramsLocalPatch)
(\a b -> b { ngramsLocalPatch = a }) state
-- Computed
let
exec { new } =
let hasChanges = new /= mempty
in when hasChanges do
T.write_ true onPending
T.write_ Nothing result
action $ Synchronize
{ afterSync: onSuccess
}
onSuccess _ = liftEffect do
T.write_ false onPending
T.write_ (Just unit) result
-- Hooks
R.useEffectOnce' $ T.listen exec ngramsLocalPatch
-- Output
pure
{ onPending
, result
}
------------------------------------------------------------------
type ResetButton = (Unit -> Aff Unit)
-> { ngramsPatches :: PatchMap NgramsTerm NgramsPatch }
-> (Action -> Effect Unit)
-> Array R.Element
chartsAfterSync :: forall props discard.
{ listIds :: Array Int
......@@ -1189,3 +518,8 @@ postNgramsChartsAsync { listIds, nodeId, session, tabType } = do
acu = AsyncNgramsChartsUpdate { listId: head listIds
, tabType }
putNgramsAsync = PostNgramsChartsAsync (Just nodeId)
tablePatchHasNgrams :: NgramsTablePatch -> NgramsTerm -> Boolean
tablePatchHasNgrams (NgramsTablePatch ngramsPatches) ngrams =
isJust $ ngramsPatches ^. _PatchMap <<< at ngrams
src/Gargantext/Core/NgramsTable/Types.purs 0 → 100644
View file @ a90287bf
module Gargantext.Core.NgramsTable.Types where
import Control.Monad.State (class MonadState, execState)
import Data.Bifunctor (lmap)
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.Index (class Index, ix)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record (prop)
import Data.List (List)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (class Newtype)
import Data.Ord.Generic (genericCompare)
import Data.Show.Generic (genericShow)
import Data.Set (Set)
import Data.Set as Set
import Data.String.Regex (Regex, regex, replace) as R
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Exception.Unsafe (unsafeThrow)
import Foreign as F
import Foreign.Object as FO
import Gargantext.Components.Table.Types as T
import Gargantext.Prelude
import Gargantext.Sessions (Session)
import Gargantext.Types as GT
import Simple.JSON as JSON
import Reactix as R
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)
---------------------------------------------------
newtype NgramsTablePatch = NgramsTablePatch NgramsPatches
derive instance Generic NgramsTablePatch _
derive instance Newtype NgramsTablePatch _
instance Eq NgramsTablePatch where eq = genericEq
derive newtype instance JSON.ReadForeign NgramsTablePatch
derive newtype instance JSON.WriteForeign NgramsTablePatch
derive newtype instance Semigroup NgramsTablePatch
derive newtype instance Monoid NgramsTablePatch
type NgramsPatches = PatchMap NgramsTerm NgramsPatch
fromMap :: forall k p. Ord k => Eq p => Monoid p => Map k p -> PatchMap k p
fromMap = PatchMap <<< Map.filter (\v -> v /= mempty)
ngramsTermText :: NgramsTerm -> String
ngramsTermText (NormNgramsTerm t) = t
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 ^^^^^^^^^^^^^
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
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
{-
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
-}
{- 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
-}
_PatchMap :: forall k p. Iso' (PatchMap k p) (Map k p)
_PatchMap = _Newtype
-- 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}
applyReplace :: forall a. Eq a => Replace a -> a -> a
applyReplace Keep a = a
applyReplace (Replace { old, new }) a
| a == old = new
| otherwise = a
applyPatchSet :: forall a. Ord a => PatchSet a -> Set a -> Set a
applyPatchSet (PatchSet p) s = Set.difference s p.rem <> p.add
applyNgramsPatch' :: forall row.
{ patch_children :: PatchSet NgramsTerm
, patch_list :: Replace GT.TermList
} ->
Endo { list :: GT.TermList
, children :: Set NgramsTerm
| row
}
applyNgramsPatch' p e =
e { list = applyReplace p.patch_list e.list
, children = applyPatchSet p.patch_children e.children
}
-- TODO
invert :: forall a. a -> a
invert _ = unsafeThrow "invert: TODO"
data NgramsPatch
= NgramsReplace
{ patch_old :: Maybe NgramsRepoElement
, patch_new :: Maybe NgramsRepoElement
}
| NgramsPatch
{ patch_children :: PatchSet NgramsTerm
, patch_list :: Replace GT.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 GT.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 :: GT.TabType
, session :: Session
| s
}
type PageParams =
CoreParams
( params :: T.Params
, searchQuery :: String
, termListFilter :: Maybe GT.TermList -- Nothing means all
, termSizeFilter :: Maybe GT.TermSize -- Nothing means all
, scoreType :: GT.ScoreType
)
-----------------------------------------------------------------------------------
newtype NgramsElement = NgramsElement
{ ngrams :: NgramsTerm -- HERE
, size :: Int -- MISSING
, list :: GT.TermList -- ok
, root :: Maybe NgramsTerm -- ok
, parent :: Maybe NgramsTerm -- ok
, children :: Set NgramsTerm -- ok
, occurrences :: Int -- HERE
}
derive instance Eq NgramsElement
derive instance Newtype NgramsElement _
derive instance Generic NgramsElement _
instance Show NgramsElement where show = genericShow
instance JSON.ReadForeign NgramsElement where
readImpl f = do
inst :: { children :: Array NgramsTerm
, size :: Int
, list :: GT.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 _ }
_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")
_NgramsElement :: Iso' NgramsElement {
children :: Set NgramsTerm
, size :: Int
, list :: GT.TermList
, ngrams :: NgramsTerm
, occurrences :: Int
, parent :: Maybe NgramsTerm
, root :: Maybe NgramsTerm
}
_NgramsElement = _Newtype
type NgramsRepoElementT =
( size :: Int
, list :: GT.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 :: GT.TermList
, parent :: Maybe NgramsTerm
, root :: Maybe NgramsTerm
-- , occurrences :: Int
}
_NgramsRepoElement = _Newtype
-----------------------------------------------------------------------------------
{-
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
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)
_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
{- NOT USED
instance EncodeJson NgramsTable where
encodeJson (NgramsTable {ngrams_repo_elements, ngrams_scores}) = encodeJson $ Map.values ... TODO
-}
--------------------------------------------
type HighlightElement = Tuple String (List (Tuple NgramsTerm GT.TermList))
type HighlightAccumulator = List HighlightElement
-----------------------------------------------------------------------------------
type VersionedNgramsTable = Versioned NgramsTable
type VersionedWithCountNgramsTable = VersionedWithCount NgramsTable
-----------------------------------------------------------------------------------
replace :: forall a. Eq a => a -> a -> Replace a
replace old new
| old == new = Keep
| otherwise = Replace { old, new }
data Replace a
= Keep
| Replace { old :: a, new :: a }
derive instance Generic (Replace a) _
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
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
derive instance Eq (PatchSet NgramsTerm)
-----------------------------------------------------
type VersionedNgramsPatches = Versioned NgramsPatches
newtype AsyncNgramsChartsUpdate = AsyncNgramsChartsUpdate {
listId :: Maybe GT.ListId
, tabType :: GT.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 GT.TermList
type RootParent = { root :: NgramsTerm, parent :: NgramsTerm }
type ReParent a = forall m. MonadState NgramsTable m => a -> m Unit
-----------------------------------------------------------------------------------
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
}
type NgramsListByTabType = Map GT.TabType VersionedNgramsTable
data CoreAction
= CommitPatch NgramsTablePatch
| Synchronize { afterSync :: Unit -> Aff Unit }
| ResetPatches
data Action
= CoreAction CoreAction
| ClearTreeEdit
| SetParentResetChildren (Maybe NgramsTerm) (List 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
type NgramsDepth = { ngrams :: NgramsTerm, depth :: Int }
type NgramsClick = NgramsDepth -> Maybe (Effect Unit)
type NgramsActionRef = R.Ref (Maybe (Unit -> Effect Unit))
type ResetButton = (Unit -> Aff Unit)
-> NgramsTablePatch
-> (Action -> Effect Unit)
-> Array R.Element
src/Gargantext/Utils/Reactix.js
View file @ a90287bf
......@@ -39,6 +39,16 @@ function blur(el) {
return el.blur();
}
function triggerEvent(el, evtType) {
// https://stackoverflow.com/questions/8789423/trigger-onchange-event
var event = new UIEvent(evtType, {
view: window,
bubbles: true,
cancelable: true
});
el.dispatchEvent(event);
}
exports._addRootElement = addRootElement;
exports._getSelection = getSelection;
exports._stringify = stringify;
......@@ -53,3 +63,4 @@ exports._keyCode = function(e) {
// https://www.w3schools.com/jsref/event_key_keycode.asp
return e.which || e.keyCode;
}
exports._triggerEvent = triggerEvent;
src/Gargantext/Utils/Reactix.purs
View file @ a90287bf
......@@ -3,25 +3,25 @@ module Gargantext.Utils.Reactix where
import Prelude
import ConvertableOptions as CO
import DOM.Simple as DOM
import DOM.Simple.Console (log2)
import DOM.Simple.Document (document)
import DOM.Simple.Element as Element
import DOM.Simple.Event as DE
import DOM.Simple.Types (class IsNode, class IsElement, DOMRect)
import Data.Array as A
import Data.Either (hush)
import Data.Function.Uncurried (Fn1, runFn1, Fn2, runFn2)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Maybe as Maybe
import Data.Nullable (Nullable, null, toMaybe)
import Data.Nullable (Nullable, notNull, null, toMaybe)
import Data.Tuple (Tuple)
import Data.Tuple.Nested ((/\))
import DOM.Simple as DOM
import DOM.Simple.Console (log2)
import DOM.Simple.Document (document)
import DOM.Simple.Element as Element
import DOM.Simple.Event as DE
import DOM.Simple.Types (class IsNode, class IsElement, DOMRect)
import Effect (Effect)
import Effect.Aff (Aff, launchAff, launchAff_, killFiber)
import Effect.Class (liftEffect)
import Effect.Exception (error)
import Effect.Uncurried (EffectFn1, EffectFn3, mkEffectFn1, mkEffectFn2, runEffectFn1, runEffectFn3)
import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn3, mkEffectFn1, mkEffectFn2, runEffectFn1, runEffectFn2, runEffectFn3)
import FFI.Simple (applyTo, args2, args3, defineProperty, delay, getProperty, (..), (...), (.=))
import Gargantext.Utils.Console (RowConsole)
import Gargantext.Utils.Console as Console
......@@ -601,3 +601,17 @@ externalOpeningFlag event = ado
metaKey <- SE.metaKey event
middleClick <- SE.button event
in ctrlKey || shiftKey || metaKey || (middleClick == 1.0)
foreign import _triggerEvent
:: forall e. EffectFn2 e String Unit
triggerEvent :: forall el. el -> String -> Effect Unit
triggerEvent = runEffectFn2 _triggerEvent
-------------------------------------------------------
setInputValue :: R.Ref (Nullable DOM.Element) -> String -> Effect Unit
setInputValue elNullableRef val = case toMaybe (R.readRef elNullableRef) of
Nothing -> pure unit
Just el -> do
_ <- pure $ (el .= "value") val
triggerEvent el "change"
triggerEvent el "input"
src/Gargantext/Utils/Toestand.purs
View file @ a90287bf
......@@ -55,4 +55,3 @@ useMemberBox val box = T.useFocused (Set.member val) (toggleSet val) box
toggleSet :: forall s. Ord s => s -> Boolean -> Set s -> Set s
toggleSet val true set = Set.insert val set
toggleSet val false set = Set.delete val set
test/Gargantext/Components/NgramsTable/Spec.purs
View file @ a90287bf
......@@ -12,7 +12,8 @@ import Test.Spec (Spec, describe, it)
import Test.Utils (shouldEqualArray)
import Gargantext.Components.NgramsTable.Core (highlightNgrams, HighlightElement, NgramsElement(..), NgramsRepoElement(..), NgramsTable(..), NgramsTerm, normNgram)
import Gargantext.Core.NgramsTable.Functions (highlightNgrams, normNgram)
import Gargantext.Core.NgramsTable.Types (HighlightElement, NgramsElement(..), NgramsRepoElement(..), NgramsTable(..), NgramsTerm)
import Gargantext.Types (CTabNgramType(..), TermList(..))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment