Commit a1b4c82f authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski Committed by Karen Konou

[ngrams] tree edit refactoring

Doesn't work yet as expected, but some progress made in good direction.
parent 83a6e5e4
module Gargantext.Components.NgramsTable module Gargantext.Components.NgramsTable
( MainNgramsTableProps ( MainNgramsTableProps
, CommonProps , CommonProps
, TreeEdit
, initialTreeEdit
, mainNgramsTable , mainNgramsTable
) where ) where
...@@ -8,11 +10,13 @@ import Gargantext.Prelude ...@@ -8,11 +10,13 @@ import Gargantext.Prelude
import Data.Array as A import Data.Array as A
import Data.FunctorWithIndex (mapWithIndex) import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (to, view, (%~), (.~), (^.), (^?)) import Data.Lens (to, view, (%~), (.~), (^.), (^?), (^..))
import Data.Lens.At (at) import Data.Lens.At (at)
import Data.Lens.Common (_Just) import Data.Lens.Common (_Just)
import Data.Lens.Fold (folded) import Data.Lens.Fold (folded)
import Data.Lens.Index (ix) import Data.Lens.Index (ix)
import Data.List (List)
import Data.List as List
import Data.Map (Map) import Data.Map (Map)
import Data.Map as Map import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe, isNothing, maybe) import Data.Maybe (Maybe(..), fromMaybe, isNothing, maybe)
...@@ -52,23 +56,33 @@ import Unsafe.Coerce (unsafeCoerce) ...@@ -52,23 +56,33 @@ import Unsafe.Coerce (unsafeCoerce)
here :: R2.Here here :: R2.Here
here = R2.here "Gargantext.Components.NgramsTable" here = R2.here "Gargantext.Components.NgramsTable"
type TreeEdit =
{ 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 = type State =
CoreState ( CoreState (
ngramsChildren :: Map NgramsTerm Boolean ngramsSelection :: Set NgramsTerm
-- ^ 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
-- ^ The set of selected checkboxes of the first column. -- ^ The set of selected checkboxes of the first column.
) )
initialTreeEdit :: TreeEdit
initialTreeEdit =
{ ngramsChildren : List.Nil
, ngramsChildrenDiff: Map.empty
, ngramsParent : Nothing }
initialState :: VersionedNgramsTable -> State initialState :: VersionedNgramsTable -> State
initialState (Versioned {version}) = { initialState (Versioned {version}) = {
ngramsChildren: Map.empty ngramsLocalPatch: mempty
, ngramsLocalPatch: mempty
, ngramsParent: Nothing
, ngramsSelection: mempty , ngramsSelection: mempty
, ngramsStagePatch: mempty , ngramsStagePatch: mempty
, ngramsValidPatch: mempty , ngramsValidPatch: mempty
...@@ -97,13 +111,12 @@ type PreConversionRows = Seq.Seq NgramsElement ...@@ -97,13 +111,12 @@ type PreConversionRows = Seq.Seq NgramsElement
type TableContainerProps = type TableContainerProps =
( dispatch :: Dispatch ( dispatch :: Dispatch
, ngramsChildren :: Map NgramsTerm Boolean
, ngramsParent :: Maybe NgramsTerm
, ngramsSelection :: Set NgramsTerm , ngramsSelection :: Set NgramsTerm
, ngramsTable :: NgramsTable , ngramsTable :: NgramsTable
, queryExactMatches :: Boolean , queryExactMatches :: Boolean
, path :: T.Box PageParams , path :: T.Box PageParams
, tabNgramType :: CTabNgramType , tabNgramType :: CTabNgramType
, treeEdit :: TreeEdit
, syncResetButton :: Array R.Element , syncResetButton :: Array R.Element
, addCallback :: String -> Effect Unit , addCallback :: String -> Effect Unit
) )
...@@ -112,13 +125,13 @@ tableContainer :: Record TableContainerProps -> Record TT.TableContainerProps -> ...@@ -112,13 +125,13 @@ tableContainer :: Record TableContainerProps -> Record TT.TableContainerProps ->
tableContainer p q = R.createElement (tableContainerCpt p) q [] tableContainer p q = R.createElement (tableContainerCpt p) q []
tableContainerCpt :: Record TableContainerProps -> R.Component TT.TableContainerProps tableContainerCpt :: Record TableContainerProps -> R.Component TT.TableContainerProps
tableContainerCpt { dispatch tableContainerCpt { dispatch
, ngramsChildren
, ngramsParent
, ngramsSelection , ngramsSelection
, ngramsTable: ngramsTableCache , ngramsTable: ngramsTableCache
, path , path
, queryExactMatches , queryExactMatches
, tabNgramType , tabNgramType
, treeEdit: { ngramsChildrenDiff
, ngramsParent }
, syncResetButton , syncResetButton
, addCallback , addCallback
} = here.component "tableContainer" cpt } = here.component "tableContainer" cpt
...@@ -210,26 +223,27 @@ tableContainerCpt { dispatch ...@@ -210,26 +223,27 @@ tableContainerCpt { dispatch
editor = H.div {} $ maybe [] edit ngramsParent editor = H.div {} $ maybe [] edit ngramsParent
where where
edit ngrams = [ H.p {} [H.text $ "Editing " <> ngramsTermText ngrams] edit ngrams = [ H.p {} [H.text $ "Editing " <> ngramsTermText ngrams]
, NTC.renderNgramsTree { ngramsTable , NTC.renderNgramsTree { ngramsChildren
, ngrams
, ngramsStyle: []
, ngramsClick , ngramsClick
, ngramsDepth
, ngramsEdit , ngramsEdit
, ngramsStyle: []
} }
, H.button { className: "btn btn-primary" , H.button { className: "btn btn-primary"
, on: {click: (const $ do , on: {click: (const $ dispatch AddTermChildren)}
dispatch AddTermChildren)}
} [H.text "Save"] } [H.text "Save"]
, H.button { className: "btn btn-primary" , H.button { className: "btn btn-primary"
, on: {click: (const $ dispatch $ SetParentResetChildren Nothing)} , on: {click: (const $ dispatch ClearTreeEdit)}
} [H.text "Cancel"] } [H.text "Cancel"]
] ]
where where
ngramsChildren = ngramsTable ^.. ix ngrams <<< _NgramsRepoElement <<< _children <<< folded
ngramsDepth = { ngrams, depth: 0 }
ngramsTable = ngramsTableCache # at ngrams ngramsTable = ngramsTableCache # at ngrams
<<< _Just <<< _Just
<<< _NgramsRepoElement <<< _NgramsRepoElement
<<< _children <<< _children
%~ applyPatchSet (patchSetFromMap ngramsChildren) %~ applyPatchSet (patchSetFromMap ngramsChildrenDiff)
ngramsClick {depth: 1, ngrams: child} = Just $ dispatch $ ToggleChild false child ngramsClick {depth: 1, ngrams: child} = Just $ dispatch $ ToggleChild false child
ngramsClick _ = Nothing ngramsClick _ = Nothing
ngramsEdit _ = Nothing ngramsEdit _ = Nothing
...@@ -265,6 +279,7 @@ type PropsNoReload = ...@@ -265,6 +279,7 @@ type PropsNoReload =
, mTotalRows :: Maybe Int , mTotalRows :: Maybe Int
, path :: T.Box PageParams , path :: T.Box PageParams
, state :: T.Box State , state :: T.Box State
, treeEdit :: T.Box TreeEdit
, versioned :: VersionedNgramsTable , versioned :: VersionedNgramsTable
| CommonProps | CommonProps
) )
...@@ -302,9 +317,11 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where ...@@ -302,9 +317,11 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where
, path , path
, state , state
, tabNgramType , tabNgramType
, treeEdit
, versioned: Versioned { data: initTable } , versioned: Versioned { data: initTable }
} _ = do } _ = do
state'@{ ngramsChildren, ngramsLocalPatch, ngramsParent, ngramsSelection } <- T.useLive T.unequal state treeEdit'@{ ngramsParent } <- T.useLive T.unequal treeEdit
state'@{ ngramsLocalPatch, ngramsSelection } <- T.useLive T.unequal state
path'@{ scoreType, termListFilter, termSizeFilter } <- T.useLive T.unequal path path'@{ scoreType, termListFilter, termSizeFilter } <- T.useLive T.unequal path
params <- T.useFocused (_.params) (\a b -> b { params = a }) path params <- T.useFocused (_.params) (\a b -> b { params = a }) path
params'@{ orderBy } <- T.useLive T.unequal params params'@{ orderBy } <- T.useLive T.unequal params
...@@ -340,7 +357,8 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where ...@@ -340,7 +357,8 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where
, rootsWithMatches , rootsWithMatches
, state: state' , state: state'
, termListFilter , termListFilter
, termSizeFilter } then , termSizeFilter
, treeEdit: treeEdit' } then
Just ngramsElement Just ngramsElement
else else
Nothing Nothing
...@@ -348,7 +366,7 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where ...@@ -348,7 +366,7 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where
performAction = mkDispatch { filteredRows performAction = mkDispatch { filteredRows
, path: path' , path: path'
, state , state
, state' } , treeEdit }
-- filteredRows :: PreConversionRows -- filteredRows :: PreConversionRows
-- no need to filter offset if cache is off -- no need to filter offset if cache is off
...@@ -414,14 +432,13 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where ...@@ -414,14 +432,13 @@ loadedNgramsTableBodyCpt = here.component "loadedNgramsTableBody" cpt where
{ colNames { colNames
, container: tableContainer , container: tableContainer
{ dispatch: performAction { dispatch: performAction
, ngramsChildren
, ngramsParent
, ngramsSelection , ngramsSelection
, ngramsTable , ngramsTable
, path , path
, queryExactMatches: exactMatches , queryExactMatches: exactMatches
, syncResetButton: [ syncResetButton ] , syncResetButton: [ syncResetButton ]
, tabNgramType , tabNgramType
, treeEdit: treeEdit'
, addCallback , addCallback
} }
, params , params
...@@ -453,60 +470,59 @@ type MkDispatchProps = ( ...@@ -453,60 +470,59 @@ type MkDispatchProps = (
filteredRows :: PreConversionRows filteredRows :: PreConversionRows
, path :: PageParams , path :: PageParams
, state :: T.Box State , state :: T.Box State
, state' :: State , treeEdit :: T.Box TreeEdit
) )
mkDispatch :: Record MkDispatchProps -> (Action -> Effect Unit) mkDispatch :: Record MkDispatchProps -> (Action -> Effect Unit)
mkDispatch { filteredRows mkDispatch { filteredRows
, path , path
, state , state
, state': { ngramsChildren , treeEdit } = performAction
, ngramsParent
, ngramsSelection } } = performAction
where where
allNgramsSelected = allNgramsSelectedOnFirstPage ngramsSelection filteredRows
setParentResetChildren :: Maybe NgramsTerm -> State -> State
setParentResetChildren p = _ { ngramsParent = p, ngramsChildren = Map.empty }
performAction :: Action -> Effect Unit performAction :: Action -> Effect Unit
performAction (SetParentResetChildren p) = performAction ClearTreeEdit =
T.modify_ (setParentResetChildren p) state T.write_ initialTreeEdit treeEdit
performAction (SetParentResetChildren p c) =
T.write_ { ngramsChildren: c
, ngramsChildrenDiff: Map.empty
, ngramsParent: p } treeEdit
performAction (ToggleChild b c) = performAction (ToggleChild b c) =
T.modify_ (\s@{ ngramsChildren: nc } -> s { ngramsChildren = newNC nc }) state T.modify_ (\g@{ ngramsChildrenDiff: nc } -> g { ngramsChildrenDiff = newNC nc }) treeEdit
where where
newNC nc = Map.alter (maybe (Just b) (const Nothing)) c nc newNC nc = Map.alter (maybe (Just b) (const Nothing)) c nc
performAction (ToggleSelect c) = performAction (ToggleSelect c) =
T.modify_ (\s@{ ngramsSelection: ns } -> s { ngramsSelection = toggleSet c ns }) state T.modify_ (\s@{ ngramsSelection: ns } -> s { ngramsSelection = toggleSet c ns }) state
performAction ToggleSelectAll = performAction ToggleSelectAll = do
T.modify_ toggler state { ngramsSelection } <- T.read state
T.modify_ (toggler ngramsSelection) state
where where
toggler s = toggler ngramsSelection s =
if allNgramsSelected then if allNgramsSelectedOnFirstPage ngramsSelection filteredRows then
s { ngramsSelection = Set.empty :: Set NgramsTerm } s { ngramsSelection = Set.empty :: Set NgramsTerm }
else else
s { ngramsSelection = selectNgramsOnFirstPage filteredRows } s { ngramsSelection = selectNgramsOnFirstPage filteredRows }
performAction AddTermChildren = do performAction AddTermChildren = do
{ ngramsChildren, ngramsChildrenDiff, ngramsParent } <- T.read treeEdit
case ngramsParent of case ngramsParent of
Nothing -> Nothing ->
-- impossible but harmless -- impossible but harmless
pure unit pure unit
Just parent -> do Just parent -> do
here.log2 "[performAction] AddTermChildren, parent" parent here.log2 "[performAction] AddTermChildren, parent" parent
here.log2 "[performAction] AddTermChildren, ngramsChildren" ngramsChildren here.log2 "[performAction] AddTermChildren, ngramsChildrenDiff" ngramsChildrenDiff
let pc = patchSetFromMap ngramsChildren let pc = patchSetFromMap ngramsChildrenDiff
pe = NgramsPatch { patch_list: mempty, patch_children: pc } pe = NgramsPatch { patch_list: mempty, patch_children: pc }
pt = singletonNgramsTablePatch parent pe pt = singletonNgramsTablePatch parent pe
T.modify_ (setParentResetChildren Nothing) state performAction ClearTreeEdit
here.log2 "[performAction] pt" pt here.log2 "[performAction] pt" pt
let ppt = case (A.head $ Set.toUnfoldable $ Map.keys ngramsChildren) of -- let ppt = case (A.head $ Set.toUnfoldable $ Map.keys ngramsChildrenDiff) of
Nothing -> mempty -- Nothing -> mempty
Just h -> -- Just h ->
let pp = NgramsPatch { patch_list: mempty -- let pp = NgramsPatch { patch_list: mempty
, patch_children: patchSetFromMap $ Map.mapMaybe (\v -> Just $ not v) ngramsChildren } -- , patch_children: patchSetFromMap $ Map.mapMaybe (\v -> Just $ not v) ngramsChildrenDiff }
in -- in
singletonNgramsTablePatch h pp -- singletonNgramsTablePatch h pp
here.log2 "[performAction] pt with patchSetFromMap" $ pt <> ppt -- here.log2 "[performAction] pt with patchSetFromMap" $ pt <> ppt
commitPatch (pt {-<> ppt-}) state commitPatch (pt {-<> ppt-}) state
performAction (CoreAction a) = coreDispatch path state a performAction (CoreAction a) = coreDispatch path state a
...@@ -516,15 +532,17 @@ displayRow :: { ngramsElement :: NgramsElement ...@@ -516,15 +532,17 @@ displayRow :: { ngramsElement :: NgramsElement
, rootsWithMatches :: Set NgramsTerm , rootsWithMatches :: Set NgramsTerm
, state :: State , state :: State
, termListFilter :: Maybe TermList , termListFilter :: Maybe TermList
, termSizeFilter :: Maybe TermSize } -> Boolean , termSizeFilter :: Maybe TermSize
, treeEdit :: TreeEdit } -> Boolean
displayRow { ngramsElement: NgramsElement {ngrams, root, list} displayRow { ngramsElement: NgramsElement {ngrams, root, list}
, ngramsParentRoot , ngramsParentRoot
, state: { ngramsChildren , state: { ngramsLocalPatch }
, ngramsLocalPatch
, ngramsParent }
, rootsWithMatches , rootsWithMatches
, termListFilter , termListFilter
, termSizeFilter } = , termSizeFilter
, treeEdit: { ngramsChildren
, ngramsChildrenDiff
, ngramsParent } } =
-- See these issues about the evolution of this filtering. -- See these issues about the evolution of this filtering.
-- * https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/340 -- * https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/340
-- * https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/87 -- * https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/87
...@@ -534,7 +552,7 @@ displayRow { ngramsElement: NgramsElement {ngrams, root, list} ...@@ -534,7 +552,7 @@ displayRow { ngramsElement: NgramsElement {ngrams, root, list}
-- ^ and which matches the search query. -- ^ and which matches the search query.
&& maybe true (_ == list) termListFilter && maybe true (_ == list) termListFilter
-- ^ and which matches the ListType filter. -- ^ 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 -- ^ and which are not scheduled to be added already
&& Just ngrams /= ngramsParent && Just ngrams /= ngramsParent
-- ^ and which are not our new parent -- ^ and which are not our new parent
...@@ -542,7 +560,7 @@ displayRow { ngramsElement: NgramsElement {ngrams, root, list} ...@@ -542,7 +560,7 @@ displayRow { ngramsElement: NgramsElement {ngrams, root, list}
-- ^ and which are not the root of our new parent -- ^ and which are not the root of our new parent
&& filterTermSize termSizeFilter ngrams && filterTermSize termSizeFilter ngrams
-- ^ and which satisfies the chosen term size -- ^ and which satisfies the chosen term size
|| ngramsChildren ^. at ngrams == Just false || ngramsChildrenDiff ^. at ngrams == Just false
-- ^ unless they are scheduled to be removed. -- ^ unless they are scheduled to be removed.
|| NTC.tablePatchHasNgrams ngramsLocalPatch ngrams || NTC.tablePatchHasNgrams ngramsLocalPatch ngrams
-- ^ unless they are being processed at the moment. -- ^ unless they are being processed at the moment.
...@@ -561,6 +579,7 @@ type MainNgramsTableProps = ( ...@@ -561,6 +579,7 @@ type MainNgramsTableProps = (
, path :: T.Box PageParams , path :: T.Box PageParams
, session :: Session , session :: Session
, tabType :: TabType , tabType :: TabType
, treeEdit :: T.Box TreeEdit
| CommonProps | CommonProps
) )
...@@ -572,6 +591,8 @@ mainNgramsTableCpt = here.component "mainNgramsTable" cpt ...@@ -572,6 +591,8 @@ mainNgramsTableCpt = here.component "mainNgramsTable" cpt
cpt props@{ cacheState, path } _ = do cpt props@{ cacheState, path } _ = do
searchQuery <- T.useFocused (_.searchQuery) (\a b -> b { searchQuery = a }) path searchQuery <- T.useFocused (_.searchQuery) (\a b -> b { searchQuery = a }) path
cacheState' <- T.useLive T.unequal cacheState cacheState' <- T.useLive T.unequal cacheState
onSave <- T.useBox Nothing
treeEdit <- T.useBox initialTreeEdit
-- let path = initialPageParams session nodeId [defaultListId] tabType -- let path = initialPageParams session nodeId [defaultListId] tabType
...@@ -579,16 +600,63 @@ mainNgramsTableCpt = here.component "mainNgramsTable" cpt ...@@ -579,16 +600,63 @@ mainNgramsTableCpt = here.component "mainNgramsTable" cpt
NT.CacheOn -> pure $ R.fragment NT.CacheOn -> pure $ R.fragment
[ [
loadedNgramsTableHeader { searchQuery } [] loadedNgramsTableHeader { searchQuery } []
, , mainNgramsTableCacheOn props []
mainNgramsTableCacheOn props []
] ]
NT.CacheOff -> pure $ R.fragment NT.CacheOff -> pure $ R.fragment
[ [
loadedNgramsTableHeader { searchQuery } [] loadedNgramsTableHeader { searchQuery } []
, , ngramsTreeEdit { onSave, treeEdit } []
mainNgramsTableCacheOff props [] , mainNgramsTableCacheOff (props { treeEdit = treeEdit }) []
] ]
type NgramsTreeEditProps =
( onSave :: T.Box (Maybe (Effect Unit))
, treeEdit :: T.Box TreeEdit )
ngramsTreeEdit :: R2.Component NgramsTreeEditProps
ngramsTreeEdit = R.createElement ngramsTreeEditCpt
ngramsTreeEditCpt :: R.Component NgramsTreeEditProps
ngramsTreeEditCpt = here.component "ngramsTreeEdit" cpt where
cpt { onSave, treeEdit } _ = do
{ ngramsParent } <- T.useLive T.unequal treeEdit
pure $ if ngramsParent == Nothing
then
H.div {} []
else
ngramsTreeEditReal { onSave, treeEdit } []
ngramsTreeEditReal :: R2.Component NgramsTreeEditProps
ngramsTreeEditReal = R.createElement ngramsTreeEditRealCpt
ngramsTreeEditRealCpt :: R.Component NgramsTreeEditProps
ngramsTreeEditRealCpt = here.component "ngramsTreeEditReal" cpt where
cpt { treeEdit } _ = do
pure $ H.div {} [ H.text "ngramsTreeEditReal" ]
-- pure $ H.div {}
-- [ H.p {}
-- [ H.text $ "Editing " <> ngramsTermText ngrams ]
-- , NTC.renderNgramsTree { ngramsClick
-- , ngramsDepth
-- , ngramsEdit
-- , ngramsStyle: []
-- , ngramsTable
-- }
-- , H.button { className: "btn btn-primary"
-- , on: {click: (const $ dispatch AddTermChildren)}
-- } [H.text "Save"]
-- , H.button { className: "btn btn-primary"
-- , on: {click: (const $ dispatch ClearTreeEdit)}
-- } [H.text "Cancel"]
-- ]
-- where
-- ngramsTable = ngramsTableCache # at ngrams
-- <<< _Just
-- <<< _NgramsRepoElement
-- <<< _children
-- %~ applyPatchSet (patchSetFromMap ngramsChildrenDiff)
-- ngramsClick {depth: 1, ngrams: child} = Just $ dispatch $ ToggleChild false child
-- ngramsClick _ = Nothing
-- ngramsEdit _ = Nothing
mainNgramsTableCacheOn :: R2.Component MainNgramsTableProps mainNgramsTableCacheOn :: R2.Component MainNgramsTableProps
mainNgramsTableCacheOn = R.createElement mainNgramsTableCacheOnCpt mainNgramsTableCacheOn = R.createElement mainNgramsTableCacheOnCpt
...@@ -599,6 +667,7 @@ mainNgramsTableCacheOnCpt = here.component "mainNgramsTableCacheOn" cpt where ...@@ -599,6 +667,7 @@ mainNgramsTableCacheOnCpt = here.component "mainNgramsTableCacheOn" cpt where
, defaultListId , defaultListId
, path , path
, tabNgramType , tabNgramType
, treeEdit
, withAutoUpdate } _ = do , withAutoUpdate } _ = do
-- let path = initialPageParams session nodeId [defaultListId] tabType -- let path = initialPageParams session nodeId [defaultListId] tabType
...@@ -609,6 +678,7 @@ mainNgramsTableCacheOnCpt = here.component "mainNgramsTableCacheOn" cpt where ...@@ -609,6 +678,7 @@ mainNgramsTableCacheOnCpt = here.component "mainNgramsTableCacheOn" cpt where
, cacheState: NT.CacheOn , cacheState: NT.CacheOn
, path , path
, tabNgramType , tabNgramType
, treeEdit
, versioned , versioned
, withAutoUpdate } [] , withAutoUpdate } []
useLoaderWithCacheAPI { useLoaderWithCacheAPI {
...@@ -641,12 +711,14 @@ mainNgramsTableCacheOffCpt = here.component "mainNgramsTableCacheOff" cpt where ...@@ -641,12 +711,14 @@ mainNgramsTableCacheOffCpt = here.component "mainNgramsTableCacheOff" cpt where
, boxes , boxes
, path , path
, tabNgramType , tabNgramType
, treeEdit
, withAutoUpdate } _ = do , withAutoUpdate } _ = do
let render versionedWithCount = mainNgramsTablePaintNoCache { afterSync let render versionedWithCount = mainNgramsTablePaintNoCache { afterSync
, boxes , boxes
, cacheState: NT.CacheOff , cacheState: NT.CacheOff
, path , path
, tabNgramType , tabNgramType
, treeEdit
, versionedWithCount , versionedWithCount
, withAutoUpdate } [] , withAutoUpdate } []
useLoaderBox { errorHandler useLoaderBox { errorHandler
...@@ -682,6 +754,7 @@ mainNgramsTableCacheOffCpt = here.component "mainNgramsTableCacheOff" cpt where ...@@ -682,6 +754,7 @@ mainNgramsTableCacheOffCpt = here.component "mainNgramsTableCacheOff" cpt where
type MainNgramsTablePaintProps = ( type MainNgramsTablePaintProps = (
cacheState :: NT.CacheState cacheState :: NT.CacheState
, treeEdit :: T.Box TreeEdit
, path :: T.Box PageParams , path :: T.Box PageParams
, versioned :: VersionedNgramsTable , versioned :: VersionedNgramsTable
| CommonProps | CommonProps
...@@ -697,6 +770,7 @@ mainNgramsTablePaintCpt = here.component "mainNgramsTablePaint" cpt ...@@ -697,6 +770,7 @@ mainNgramsTablePaintCpt = here.component "mainNgramsTablePaint" cpt
, cacheState , cacheState
, path , path
, tabNgramType , tabNgramType
, treeEdit
, versioned , versioned
, withAutoUpdate } _ = do , withAutoUpdate } _ = do
state <- T.useBox $ initialState versioned state <- T.useBox $ initialState versioned
...@@ -711,6 +785,7 @@ mainNgramsTablePaintCpt = here.component "mainNgramsTablePaint" cpt ...@@ -711,6 +785,7 @@ mainNgramsTablePaintCpt = here.component "mainNgramsTablePaint" cpt
, path , path
, state , state
, tabNgramType , tabNgramType
, treeEdit
, versioned , versioned
, withAutoUpdate , withAutoUpdate
} [] } []
...@@ -718,6 +793,7 @@ mainNgramsTablePaintCpt = here.component "mainNgramsTablePaint" cpt ...@@ -718,6 +793,7 @@ mainNgramsTablePaintCpt = here.component "mainNgramsTablePaint" cpt
type MainNgramsTablePaintNoCacheProps = ( type MainNgramsTablePaintNoCacheProps = (
cacheState :: NT.CacheState cacheState :: NT.CacheState
, path :: T.Box PageParams , path :: T.Box PageParams
, treeEdit :: T.Box TreeEdit
, versionedWithCount :: VersionedWithCountNgramsTable , versionedWithCount :: VersionedWithCountNgramsTable
| CommonProps | CommonProps
) )
...@@ -732,6 +808,7 @@ mainNgramsTablePaintNoCacheCpt = here.component "mainNgramsTablePaintNoCache" cp ...@@ -732,6 +808,7 @@ mainNgramsTablePaintNoCacheCpt = here.component "mainNgramsTablePaintNoCache" cp
, cacheState , cacheState
, path , path
, tabNgramType , tabNgramType
, treeEdit
, versionedWithCount , versionedWithCount
, withAutoUpdate } _ = do , withAutoUpdate } _ = do
-- TODO This is lame, make versionedWithCount a proper box? -- TODO This is lame, make versionedWithCount a proper box?
...@@ -749,6 +826,7 @@ mainNgramsTablePaintNoCacheCpt = here.component "mainNgramsTablePaintNoCache" cp ...@@ -749,6 +826,7 @@ mainNgramsTablePaintNoCacheCpt = here.component "mainNgramsTablePaintNoCache" cp
, path , path
, state , state
, tabNgramType , tabNgramType
, treeEdit
, versioned , versioned
, withAutoUpdate } [] , withAutoUpdate } []
......
...@@ -4,6 +4,7 @@ import Data.Lens ((^..), (^.), view) ...@@ -4,6 +4,7 @@ import Data.Lens ((^..), (^.), view)
import Data.Lens.At (at) import Data.Lens.At (at)
import Data.Lens.Fold (folded) import Data.Lens.Fold (folded)
import Data.Lens.Index (ix) import Data.Lens.Index (ix)
import Data.List (List)
import Data.List (null, toUnfoldable) as L import Data.List (null, toUnfoldable) as L
import Data.Maybe (Maybe(..), maybe, isJust) import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Nullable (null, toMaybe) import Data.Nullable (null, toMaybe)
...@@ -117,35 +118,35 @@ selectionCheckboxCpt = here.component "selectionCheckbox" cpt ...@@ -117,35 +118,35 @@ selectionCheckboxCpt = here.component "selectionCheckbox" cpt
type RenderNgramsTree = type RenderNgramsTree =
( ngrams :: NgramsTerm ( ngramsChildren :: List NgramsTerm
, ngramsClick :: NgramsClick , ngramsClick :: NgramsClick
, ngramsEdit :: NgramsClick , ngramsDepth :: NgramsDepth
, ngramsStyle :: Array DOM.Props , ngramsEdit :: NgramsClick
, ngramsTable :: NgramsTable , ngramsStyle :: Array DOM.Props
--, ngramsTable :: NgramsTable
) )
renderNgramsTree :: Record RenderNgramsTree -> R.Element renderNgramsTree :: Record RenderNgramsTree -> R.Element
renderNgramsTree p = R.createElement renderNgramsTreeCpt p [] renderNgramsTree p = R.createElement renderNgramsTreeCpt p []
renderNgramsTreeCpt :: R.Component RenderNgramsTree renderNgramsTreeCpt :: R.Component RenderNgramsTree
renderNgramsTreeCpt = here.component "renderNgramsTree" cpt renderNgramsTreeCpt = here.component "renderNgramsTree" cpt
where where
cpt { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit} _ = cpt { ngramsChildren, ngramsClick, ngramsDepth, ngramsEdit, ngramsStyle } _ =
pure $ H.ul {} [ pure $ H.ul {}
H.span { className: "tree" } [ [ H.span { className: "tree" }
H.span { className: "righthanded" } [ [ H.span { className: "righthanded" }
tree { ngramsClick [ tree { ngramsChildren
, ngramsDepth: {ngrams, depth: 0} , ngramsClick
, ngramsDepth
, ngramsEdit , ngramsEdit
, ngramsStyle , ngramsStyle
, ngramsTable
} }
] ]
] ]
] ]
type NgramsDepth = {ngrams :: NgramsTerm, depth :: Int} type NgramsDepth = { ngrams :: NgramsTerm, depth :: Int }
type NgramsClick = NgramsDepth -> Maybe (Effect Unit) type NgramsClick = NgramsDepth -> Maybe (Effect Unit)
type TagProps = type TagProps =
...@@ -165,24 +166,28 @@ tag tagProps = ...@@ -165,24 +166,28 @@ tag tagProps =
-} -}
type TreeProps = type TreeProps =
( ngramsEdit :: NgramsClick ( ngramsChildren :: List NgramsTerm
, ngramsTable :: NgramsTable , ngramsEdit :: NgramsClick
--, ngramsTable :: NgramsTable
| TagProps | TagProps
) )
tree :: Record TreeProps -> R.Element tree :: Record TreeProps -> R.Element
tree p = R.createElement treeCpt p [] tree p = R.createElement treeCpt p []
treeCpt :: R.Component TreeProps treeCpt :: R.Component TreeProps
treeCpt = here.component "tree" cpt treeCpt = here.component "tree" cpt
where where
cpt params@{ ngramsClick, ngramsDepth, ngramsEdit, ngramsStyle, ngramsTable } _ = cpt params@{ ngramsChildren, ngramsClick, ngramsDepth, ngramsEdit, ngramsStyle } _ = do
R.useEffect' $ do
here.log2 "[tree] ngramsChildren" ngramsChildren
pure $ pure $
H.li { style: {width : "100%"} } H.li { style: { width : "100%" } }
([ H.i { className, style } [] ] ([ H.i { className, style } [] ]
<> [ R2.buff $ tag [ text $ " " <> ngramsTermText ngramsDepth.ngrams ] ] <> [ R2.buff $ tag [ text $ " " <> ngramsTermText ngramsDepth.ngrams ] ]
<> maybe [] edit (ngramsEdit ngramsDepth) <> maybe [] edit (ngramsEdit ngramsDepth)
<> [ forest cs ] <> [ forest ngramsChildren ]
) )
where where
tag = tag =
...@@ -195,11 +200,11 @@ treeCpt = here.component "tree" cpt ...@@ -195,11 +200,11 @@ treeCpt = here.component "tree" cpt
, H.i { className: "fa fa-pencil" , H.i { className: "fa fa-pencil"
, on: { click: const effect } } [] , on: { click: const effect } } []
] ]
leaf = L.null cs leaf = L.null ngramsChildren
className = "fa fa-chevron-" <> if open then "down" else "right" className = "fa fa-chevron-" <> if open then "down" else "right"
style = if leaf then {color: "#adb5bd"} else {color: ""} style = if leaf then {color: "#adb5bd"} else {color: ""}
open = not leaf || false {- TODO -} open = not leaf || false {- TODO -}
cs = ngramsTable ^.. ix ngramsDepth.ngrams <<< _NgramsRepoElement <<< _children <<< folded --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. -- cs has a list is ok, the length is the number of direct children of an ngram which is generally < 10.
forest = forest =
...@@ -233,25 +238,30 @@ renderNgramsItemCpt = here.component "renderNgramsItem" cpt ...@@ -233,25 +238,30 @@ renderNgramsItemCpt = here.component "renderNgramsItem" cpt
, ngramsSelection , ngramsSelection
, ngramsTable , ngramsTable
} _ = do } _ = do
pure $ Tbl.makeRow [ pure $ Tbl.makeRow
H.div { className: "ngrams-selector" } [ [ H.div { className: "ngrams-selector" }
H.span { className: "ngrams-chooser fa fa-eye-slash" [ H.span { className: "ngrams-chooser fa fa-eye-slash"
, on: { click: onClick } } [] , on: { click: onClick } } []
] ]
, selected , selected
, checkbox GT.MapTerm , checkbox GT.MapTerm
, checkbox GT.StopTerm , checkbox GT.StopTerm
, H.div {} ( if ngramsParent == Nothing , H.div {}
then [renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit }] ( if ngramsParent == Nothing
else [H.a { on: { click: const $ dispatch $ ToggleChild true ngrams } } then [renderNgramsTree { ngramsChildren
[ H.i { className: "fa fa-plus" } []] , ngramsClick
, R2.buff $ tag [ text $ " " <> ngramsTermText ngramsDepth.ngrams ] , ngramsDepth
] , ngramsEdit
) , ngramsStyle }]
else [H.a { on: { click: const $ dispatch $ ToggleChild true ngrams } }
[ H.i { className: "fa fa-plus" } []]
, R2.buff $ tag [ text $ " " <> ngramsTermText ngramsDepth.ngrams ]
]
)
, H.text $ show (ngramsElement ^. _NgramsElement <<< _occurrences) , H.text $ show (ngramsElement ^. _NgramsElement <<< _occurrences)
] ]
where where
ngramsDepth= {ngrams, depth: 0 } ngramsDepth= { ngrams, depth: 0 }
tag = tag =
case ngramsClick ngramsDepth of case ngramsClick ngramsDepth of
Just effect -> Just effect ->
...@@ -263,7 +273,8 @@ renderNgramsItemCpt = here.component "renderNgramsItem" cpt ...@@ -263,7 +273,8 @@ renderNgramsItemCpt = here.component "renderNgramsItem" cpt
-- R2.callTrigger toggleSidePanel unit -- R2.callTrigger toggleSidePanel unit
termList = ngramsElement ^. _NgramsElement <<< _list termList = ngramsElement ^. _NgramsElement <<< _list
ngramsStyle = [termStyle termList ngramsOpacity] ngramsStyle = [termStyle termList ngramsOpacity]
ngramsEdit = Just <<< dispatch <<< SetParentResetChildren <<< Just <<< view _ngrams ngramsEdit { ngrams } = Just $ dispatch $ SetParentResetChildren (Just ngrams) ngramsChildren
ngramsChildren = ngramsTable ^.. ix ngrams <<< _NgramsRepoElement <<< _children <<< folded
ngramsClick = ngramsClick =
Just <<< dispatch <<< CoreAction <<< cycleTermListItem <<< view _ngrams Just <<< dispatch <<< CoreAction <<< cycleTermListItem <<< view _ngrams
-- ^ This is the old behavior it is nicer to use since one can -- ^ This is the old behavior it is nicer to use since one can
......
...@@ -1020,7 +1020,8 @@ data CoreAction ...@@ -1020,7 +1020,8 @@ data CoreAction
data Action data Action
= CoreAction CoreAction = CoreAction CoreAction
| SetParentResetChildren (Maybe NgramsTerm) | ClearTreeEdit
| SetParentResetChildren (Maybe NgramsTerm) (List NgramsTerm)
-- ^ This sets `ngramsParent` and resets `ngramsChildren`. -- ^ This sets `ngramsParent` and resets `ngramsChildren`.
| ToggleChild Boolean NgramsTerm | ToggleChild Boolean NgramsTerm
-- ^ Toggles the NgramsTerm in the `PatchSet` `ngramsChildren`. -- ^ Toggles the NgramsTerm in the `PatchSet` `ngramsChildren`.
......
...@@ -113,18 +113,21 @@ ngramsViewCpt = here.component "ngramsView" cpt where ...@@ -113,18 +113,21 @@ ngramsViewCpt = here.component "ngramsView" cpt where
NTC.initialPageParams session nodeId NTC.initialPageParams session nodeId
[ defaultListId ] (TabDocument TabDocs) [ defaultListId ] (TabDocument TabDocs)
pure $ NT.mainNgramsTable (props' path) [] where treeEdit <- T.useBox NT.initialTreeEdit
most = RX.pick props :: Record NTCommon
props' path = pure $ NT.mainNgramsTable (props' treeEdit path) []
(Record.merge most where
{ afterSync most = RX.pick props :: Record NTCommon
, path props' treeEdit path =
, tabType: TabPairing (TabNgramType $ modeTabType mode) (Record.merge most
, tabNgramType: modeTabType' mode { afterSync
, withAutoUpdate: false }) :: Record NT.MainNgramsTableProps , path
where , tabType: TabPairing (TabNgramType $ modeTabType mode)
afterSync :: Unit -> Aff Unit , tabNgramType: modeTabType' mode
afterSync _ = pure unit , treeEdit
, withAutoUpdate: false }) :: Record NT.MainNgramsTableProps
afterSync :: Unit -> Aff Unit
afterSync _ = pure unit
type NTCommon = type NTCommon =
( boxes :: Boxes ( boxes :: Boxes
......
...@@ -146,6 +146,7 @@ ngramsViewCpt = here.component "ngramsView" cpt ...@@ -146,6 +146,7 @@ ngramsViewCpt = here.component "ngramsView" cpt
, nodeId , nodeId
, session } _ = do , session } _ = do
path <- T.useBox $ NTC.initialPageParams session nodeId [defaultListId] (TabDocument TabDocs) path <- T.useBox $ NTC.initialPageParams session nodeId [defaultListId] (TabDocument TabDocs)
treeEdit <- T.useBox NT.initialTreeEdit
pure $ NT.mainNgramsTable { pure $ NT.mainNgramsTable {
afterSync: \_ -> pure unit afterSync: \_ -> pure unit
...@@ -156,6 +157,7 @@ ngramsViewCpt = here.component "ngramsView" cpt ...@@ -156,6 +157,7 @@ ngramsViewCpt = here.component "ngramsView" cpt
, session , session
, tabNgramType , tabNgramType
, tabType , tabType
, treeEdit
, withAutoUpdate: false , withAutoUpdate: false
} [] } []
where where
......
...@@ -89,6 +89,7 @@ ngramsViewCpt = here.component "ngramsView" cpt where ...@@ -89,6 +89,7 @@ ngramsViewCpt = here.component "ngramsView" cpt where
, session , session
, path } _ = do , path } _ = do
chartsReload <- T.useBox T2.newReload chartsReload <- T.useBox T2.newReload
treeEdit <- T.useBox NT.initialTreeEdit
{ listIds, nodeId, params } <- T.useLive T.unequal path { listIds, nodeId, params } <- T.useLive T.unequal path
...@@ -114,6 +115,7 @@ ngramsViewCpt = here.component "ngramsView" cpt where ...@@ -114,6 +115,7 @@ ngramsViewCpt = here.component "ngramsView" cpt where
, session , session
, tabNgramType , tabNgramType
, tabType , tabType
, treeEdit
, withAutoUpdate: false , withAutoUpdate: false
} [] } []
] ]
......
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