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
This diff is collapsed.
...@@ -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