module Gargantext.Components.NgramsTable ( Action , MainNgramsTableProps , initialState , mainNgramsTableSpec , ngramsTableClass , ngramsTableSpec , termStyle ) where import Control.Monad.Cont.Trans (lift) import Data.Array as A import Data.Lens (to, view, (%~), (.~), (^.), (^..)) import Data.Lens.Common (_Just) import Data.Lens.At (at) import Data.Lens.Index (ix) import Data.Lens.Fold (folded) import Data.Lens.Record (prop) import Data.List as List import Data.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(..), maybe) import Data.Monoid.Additive (Additive(..)) import Data.Ord.Down (Down(..)) import Data.Symbol (SProxy(..)) import Data.Tuple (Tuple(..), snd) import Effect (Effect) import React (ReactElement) import React.DOM (a, button, div, h2, i, input, li, option, p, select, span, table, tbody, text, thead, ul) import React.DOM.Props (_id, _type, checked, className, name, onChange, onClick, onInput, placeholder, style, value) import React.DOM.Props as DOM import Thermite (PerformAction, Render, Spec, defaultPerformAction, modifyState_, simpleSpec, createClass) import Unsafe.Coerce (unsafeCoerce) import Gargantext.Types (TermList(..), readTermList, readTermSize, termLists, termSizes) import Gargantext.Config (OrderBy(..), TabType, CTabNgramType(..)) import Gargantext.Components.AutoUpdate (autoUpdateElt) import Gargantext.Components.Table as T import Gargantext.Prelude import Gargantext.Components.Loader as Loader import Gargantext.Components.NgramsTable.Core type State = CoreState ( ngramsParent :: Maybe NgramsTerm -- Nothing means we are not currently grouping terms , 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. ) _ngramsChildren = prop (SProxy :: SProxy "ngramsChildren") initialState :: forall props. { loaded :: VersionedNgramsTable | props } -> State initialState {loaded: Versioned {version}} = { ngramsTablePatch: mempty , ngramsVersion: version , ngramsParent: Nothing , ngramsChildren: mempty } data Action = SetTermListItem NgramsTerm (Replace TermList) | 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 -- NgramsTable -- ^ The NgramsTable argument is here as a cache of `ngramsTablePatch` -- applied to `initTable`. -- TODO more docs | Refresh | AddNewNgram NgramsTerm type Dispatch = Action -> Effect Unit type LoaderAction = Loader.Action PageParams type LoaderDispatch = LoaderAction -> Effect Unit tableContainer :: { pageParams :: PageParams , dispatch :: Dispatch , loaderDispatch :: LoaderDispatch , ngramsParent :: Maybe NgramsTerm , ngramsChildren :: Map NgramsTerm Boolean , ngramsTable :: NgramsTable } -> T.TableContainerProps -> Array ReactElement tableContainer { pageParams , dispatch , loaderDispatch , ngramsParent , ngramsChildren , ngramsTable: ngramsTableCache } props = [ div [className "container-fluid"] [ div [className "jumbotron1"] [ div [className "row"] [ div [className "panel panel-default"] [ div [className "panel-heading"] [ h2 [className "panel-title", style {textAlign : "center"}] [ span [className "glyphicon glyphicon-hand-down"] [] , text "Extracted Terms" ] , div [className "row"] [ {-div [className "savediv pull-left col-md-2", style { marginTop :"35px"}] [ button [_id "ImportListOrSaveAll", className "btn btn-warning", style {fontSize : "120%"}] [ text "Import a Termlist" ] ] ,-} div [className "col-md-3", style {marginTop : "6px"}] [ input [ className "form-control " , name "search", placeholder "Search" , _type "value" , value pageParams.searchQuery , onInput \e -> setSearchQuery (unsafeEventValue e) ] , div [] ( if A.null props.tableBody && pageParams.searchQuery /= "" then [ button [ className "btn btn-primary" , onClick $ const $ dispatch $ AddNewNgram pageParams.searchQuery ] [text $ "Add " <> pageParams.searchQuery] ] else [] ) ] , div [className "col-md-2", style {marginTop : "6px"}] [ li [className " list-group-item"] [ select [ _id "picklistmenu" , className "form-control custom-select" , value (maybe "" show pageParams.termListFilter) , onChange (\e -> setTermListFilter $ readTermList $ unsafeEventValue e) ] $ map optps1 termLists ] ] , div [className "col-md-2", style {marginTop : "6px"}] [ li [className "list-group-item"] [ select [ _id "picktermtype" , className "form-control custom-select" , value (maybe "" show pageParams.termSizeFilter) , onChange (\e -> setTermSizeFilter $ readTermSize $ unsafeEventValue e) ] $ map optps1 termSizes ] ] , div [className "col-md-4", style {marginTop : "6px", marginBottom : "1px"}] [ li [className " list-group-item"] [ props.pageSizeDescription , props.pageSizeControl , text " items / " , props.paginationLinks ] --, li [className " list-group-item"] [ props.pageSizeControl ] ] ] ] , div [] (maybe [] (\ngrams -> let ngramsTable = ngramsTableCache # at ngrams <<< _Just <<< _NgramsElement <<< _children %~ applyPatchSet (patchSetFromMap ngramsChildren) ngramsClick {depth: 1, ngrams: child} = Just $ dispatch $ ToggleChild false child ngramsClick _ = Nothing ngramsEdit _ = Nothing in [ p[] [text $ "Editing " <> ngrams] , renderNgramsTree { ngramsTable, ngrams, ngramsStyle: [], ngramsClick, ngramsEdit } , button [className "btn btn-primary", onClick $ const $ dispatch $ AddTermChildren] [text "Save"] , button [className "btn btn-secondary", onClick $ const $ dispatch $ SetParentResetChildren Nothing] [text "Cancel"] ]) ngramsParent) , div [ _id "terms_table", className "panel-body" ] [ table [ className "table able" ] [ thead [ className "tableHeader"] [props.tableHead] , tbody [] props.tableBody ] ] ] ] ] ] ] where setPageParams f = loaderDispatch $ Loader.SetPath $ f pageParams setSearchQuery x = setPageParams $ _ { searchQuery = x } setTermListFilter x = setPageParams $ _ { termListFilter = x } setTermSizeFilter x = setPageParams $ _ { termSizeFilter = x } toggleMap :: forall a. a -> Maybe a -> Maybe a toggleMap _ (Just _) = Nothing toggleMap b Nothing = Just b ngramsTableSpec :: CTabNgramType -> Spec State LoadedNgramsTableProps Action ngramsTableSpec ntype = simpleSpec performAction render where setParentResetChildren :: Maybe NgramsTerm -> State -> State setParentResetChildren p = _ { ngramsParent = p, ngramsChildren = mempty } performAction :: PerformAction State LoadedNgramsTableProps Action performAction (SetParentResetChildren p) _ _ = modifyState_ $ setParentResetChildren p performAction (ToggleChild b c) _ _ = modifyState_ $ _ngramsChildren <<< at c %~ toggleMap b performAction Refresh {path: {nodeId, listIds, tabType}} {ngramsVersion} = do commitPatch {nodeId, listIds, tabType} (Versioned {version: ngramsVersion, data: mempty}) performAction (SetTermListItem n pl) {path: {nodeId, listIds, tabType}} {ngramsVersion} = commitPatch {nodeId, listIds, tabType} (Versioned {version: ngramsVersion, data: pt}) where pe = NgramsPatch { patch_list: pl, patch_children: mempty } pt = singletonNgramsTablePatch ntype n pe performAction AddTermChildren _ {ngramsParent: Nothing} = -- impossible but harmless pure unit performAction AddTermChildren {path: {nodeId, listIds, tabType}} { ngramsParent: Just parent , ngramsChildren , ngramsVersion } = do modifyState_ $ setParentResetChildren Nothing commitPatch {nodeId, listIds, tabType} (Versioned {version: ngramsVersion, data: pt}) where pc = patchSetFromMap ngramsChildren pe = NgramsPatch { patch_list: mempty, patch_children: pc } pt = singletonNgramsTablePatch ntype parent pe performAction (AddNewNgram ngram) {path: {listIds, nodeId, tabType}} {ngramsVersion} = commitPatch {listIds, nodeId, tabType} (Versioned {version: ngramsVersion, data: pt}) where pt = addNewNgram ntype ngram CandidateTerm render :: Render State LoadedNgramsTableProps Action render dispatch { path: pageParams , loaded: Versioned { data: initTable } , dispatch: loaderDispatch } { ngramsTablePatch, ngramsParent, ngramsChildren } _reactChildren = [ autoUpdateElt { duration: 3000 , effect: dispatch Refresh } , T.tableElt { rows , setParams , container: tableContainer {pageParams, loaderDispatch, dispatch, ngramsParent, ngramsChildren, ngramsTable} , colNames: T.ColumnName <$> [ "Map" , "Stop" , "Terms" , "Score (Occurrences)" -- see convOrderBy ] , totalRecords: 47361 -- TODO } ] where setParams params = loaderDispatch $ Loader.SetPath $ pageParams {params = params} ngramsTable = applyNgramsTablePatch ngramsTablePatch initTable orderWith = case convOrderBy <$> pageParams.params.orderBy of Just ScoreAsc -> A.sortWith \x -> (snd x) ^. _NgramsElement <<< _occurrences Just ScoreDesc -> A.sortWith \x -> Down $ (snd x) ^. _NgramsElement <<< _occurrences _ -> identity -- the server ordering is enough here rows = convertRow <$> orderWith (addOcc <$> Map.toUnfoldable (Map.filter displayRow (ngramsTable ^. _NgramsTable))) addOcc (Tuple ne ngramsElement) = let Additive occurrences = sumOccurrences ngramsTable ngramsElement in Tuple ne (ngramsElement # _NgramsElement <<< _occurrences .~ occurrences) ngramsParentRoot :: Maybe String ngramsParentRoot = (\np -> ngramsTable ^. at np <<< _Just <<< _NgramsElement <<< _root) =<< ngramsParent displayRow (NgramsElement {ngrams, root}) = root == Nothing -- ^ Display only nodes without parents && ngramsChildren ^. at ngrams /= Just true -- ^ and which are not scheduled to be added already && Just ngrams /= ngramsParent -- ^ and which are not our new parent && Just ngrams /= ngramsParentRoot -- ^ and which are not the root of our new parent || -- Unless they are scheduled to be removed. ngramsChildren ^. at ngrams == Just false convertRow (Tuple ngrams ngramsElement) = { row: renderNgramsItem { ngramsTable, ngrams, ngramsParent, ngramsElement, dispatch} , delete: false } ngramsTableClass :: CTabNgramType -> Loader.InnerClass PageParams VersionedNgramsTable ngramsTableClass ct = createClass "NgramsTable" (ngramsTableSpec ct) initialState type MainNgramsTableProps = { nodeId :: Int -- ^ This node can be a corpus or contact. , defaultListId :: Int , tabType :: TabType } mainNgramsTableSpec :: CTabNgramType -> Spec {} MainNgramsTableProps Void mainNgramsTableSpec nt = simpleSpec defaultPerformAction render where render :: Render {} MainNgramsTableProps Void render _ {nodeId, defaultListId, tabType} _ _ = [ ngramsLoader { path: initialPageParams nodeId [defaultListId] tabType , component: (ngramsTableClass nt) } ] type NgramsDepth = {ngrams :: NgramsTerm, depth :: Int} type NgramsClick = NgramsDepth -> Maybe (Effect Unit) tree :: { ngramsTable :: NgramsTable , ngramsStyle :: Array DOM.Props , ngramsEdit :: NgramsClick , ngramsClick :: NgramsClick } -> NgramsDepth -> ReactElement tree params@{ngramsTable, ngramsStyle, ngramsEdit, ngramsClick} nd@{ngrams} = li [ style {width : "100%"} ] ([ i icon [] , tag [text $ " " <> ngrams] ] <> maybe [] edit (ngramsEdit nd) <> [ forest cs ]) where tag = case ngramsClick nd of Just effect -> a (ngramsStyle <> [onClick $ const effect]) Nothing -> span ngramsStyle edit effect = [ text " " , i [ className "glyphicon glyphicon-pencil" , onClick $ const effect ] [] ] leaf = List.null cs icon = gray <> [className $ "glyphicon glyphicon-chevron-" <> if open then "down" else "right"] open = not leaf || false {- TODO -} gray = if leaf then [style {color: "#adb5bd"}] else [] cs = ngramsTable ^.. ix ngrams <<< _NgramsElement <<< _children <<< folded forest = let depth = nd.depth + 1 in ul [] <<< map (\ngrams -> tree params {depth, ngrams}) <<< List.toUnfoldable sumOccurrences' :: NgramsTable -> NgramsTerm -> Additive Int sumOccurrences' ngramsTable label = ngramsTable ^. ix label <<< to (sumOccurrences ngramsTable) sumOccurrences :: NgramsTable -> NgramsElement -> Additive Int sumOccurrences ngramsTable (NgramsElement {occurrences, children}) = Additive occurrences <> children ^. folded <<< to (sumOccurrences' ngramsTable) renderNgramsTree :: { ngrams :: NgramsTerm , ngramsTable :: NgramsTable , ngramsStyle :: Array DOM.Props , ngramsClick :: NgramsClick , ngramsEdit :: NgramsClick } -> ReactElement renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit } = ul [] [ span [className "tree"] [tree {ngramsTable, ngramsStyle, ngramsClick, ngramsEdit} {ngrams, depth: 0}] ] renderNgramsItem :: { ngrams :: NgramsTerm , ngramsTable :: NgramsTable , ngramsElement :: NgramsElement , ngramsParent :: Maybe NgramsTerm , dispatch :: Action -> Effect Unit } -> Array ReactElement renderNgramsItem { ngramsTable, ngrams, ngramsElement, ngramsParent, dispatch } = [ checkbox GraphTerm , checkbox StopTerm , if ngramsParent == Nothing then renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit } else a [onClick $ const $ dispatch $ ToggleChild true ngrams] [ i [className "glyphicon glyphicon-plus"] [] , span ngramsStyle [text $ " " <> ngrams] ] , text $ show (ngramsElement ^. _NgramsElement <<< _occurrences) ] where termList = ngramsElement ^. _NgramsElement <<< _list ngramsStyle = [termStyle termList] ngramsEdit = Just <<< dispatch <<< SetParentResetChildren <<< Just <<< view _ngrams ngramsClick = Just <<< cycleTermListItem <<< view _ngrams checkbox termList' = let chkd = termList == termList' termList'' = if chkd then CandidateTerm else termList' in input [ _type "checkbox" , className "checkbox" , checked chkd -- , title "Mark as completed" , onChange $ const $ setTermList (replace termList termList'') ngrams ] setTermList Keep _ = pure unit setTermList rep@(Replace {old,new}) n = dispatch $ SetTermListItem n rep cycleTermListItem = setTermList (replace termList (nextTermList termList)) termStyle :: TermList -> DOM.Props termStyle GraphTerm = style {color: "green"} termStyle StopTerm = style {color: "red", textDecoration : "line-through"} termStyle CandidateTerm = style {color: "black"} nextTermList :: TermList -> TermList nextTermList GraphTerm = StopTerm nextTermList StopTerm = CandidateTerm nextTermList CandidateTerm = GraphTerm optps1 :: forall a. Show a => { desc :: String, mval :: Maybe a } -> ReactElement optps1 { desc, mval } = option [value val] [text desc] where val = maybe "" show mval unsafeEventValue :: forall event. event -> String unsafeEventValue e = (unsafeCoerce e).target.value