NgramsTable.purs 17.9 KB
Newer Older
1
module Gargantext.Components.NgramsTable
2
  ( Action
3
  , MainNgramsTableProps
4
  , initialState
5
  , mainNgramsTableSpec
6
  , ngramsTableClass
7 8
  , ngramsTableSpec
  , termStyle
9 10 11
  )
  where

12
import Control.Monad.Cont.Trans (lift)
13
import Data.Array as A
14
import Data.Lens (to, view, (%~), (.~), (^.), (^..))
15
import Data.Lens.Common (_Just)
16 17 18
import Data.Lens.At (at)
import Data.Lens.Index (ix)
import Data.Lens.Fold (folded)
19 20 21 22 23
import Data.Lens.Record (prop)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
24
import Data.Monoid.Additive (Additive(..))
25
import Data.Ord.Down (Down(..))
26
import Data.Symbol (SProxy(..))
27
import Data.Tuple (Tuple(..), snd)
28 29 30
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)
31
import React.DOM.Props (_id, _type, checked, className, name, onChange, onClick, onInput, placeholder, style, value)
32
import React.DOM.Props as DOM
33
import Thermite (PerformAction, Render, Spec, defaultPerformAction, modifyState_, simpleSpec, createClass)
34 35
import Unsafe.Coerce (unsafeCoerce)

36 37
import Gargantext.Types (TermList(..), readTermList, readTermSize, termLists, termSizes)
import Gargantext.Config (OrderBy(..), TabType)
38
import Gargantext.Components.AutoUpdate (autoUpdateElt)
39 40 41
import Gargantext.Components.Table as T
import Gargantext.Prelude
import Gargantext.Components.Loader as Loader
42
import Gargantext.Components.NgramsTable.Core
43 44

type State =
45 46
  CoreState
  ( ngramsParent     :: Maybe NgramsTerm -- Nothing means we are not currently grouping terms
47 48 49 50 51
  , 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.
52
  )
53 54 55

_ngramsChildren = prop (SProxy :: SProxy "ngramsChildren")

56 57 58
initialState :: forall props. { loaded :: VersionedNgramsTable | props }
             -> State
initialState {loaded: Versioned {version}} =
59
  { ngramsTablePatch: mempty
60
  , ngramsVersion:    version
61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
  , 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
77
  | Refresh
78
  | AddNewNgram NgramsTerm
79 80 81

type Dispatch = Action -> Effect Unit

82 83 84 85 86
type LoaderAction = Loader.Action PageParams

type LoaderDispatch = LoaderAction -> Effect Unit

tableContainer :: { pageParams :: PageParams
87
                  , dispatch :: Dispatch
88
                  , loaderDispatch :: LoaderDispatch
89 90 91 92 93
                  , ngramsParent :: Maybe NgramsTerm
                  , ngramsChildren :: Map NgramsTerm Boolean
                  , ngramsTable :: NgramsTable
                  }
               -> T.TableContainerProps -> Array ReactElement
94 95 96 97 98 99 100
tableContainer { pageParams
               , dispatch
               , loaderDispatch
               , ngramsParent
               , ngramsChildren
               , ngramsTable: ngramsTableCache
               } props =
101 102 103 104 105 106 107 108 109 110
  [ 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"]
111 112
              [
              {-div [className "savediv pull-left col-md-2", style { marginTop :"35px"}]
113
                [  button [_id "ImportListOrSaveAll", className "btn btn-warning", style {fontSize : "120%"}]
114 115
                  [ text "Import a Termlist" ]
                ]
116
              ,-}
117
                div [className "col-md-3", style {marginTop : "6px"}]
118 119 120
                [ input [ className "form-control "
                        , name "search", placeholder "Search"
                        , _type "value"
121 122
                        , value pageParams.searchQuery
                        , onInput \e -> setSearchQuery (unsafeEventValue e)
123
                        ]
124 125 126 127 128 129 130
                , 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 []
                  )
131
                ]
132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
              , 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 ]
158 159 160 161 162 163 164 165 166 167 168
                ]
              ]
            ]
          , div [] (maybe [] (\ngrams ->
              let
                ngramsTable =
                  ngramsTableCache # at ngrams
                                 <<< _Just
                                 <<< _NgramsElement
                                 <<< _children
                                 %~ applyPatchSet (patchSetFromMap ngramsChildren)
169 170 171
                ngramsClick {depth: 1, ngrams: child} =
                  Just $ dispatch $ ToggleChild false child
                ngramsClick _ = Nothing
172
                ngramsEdit _ = Nothing
173 174
              in
              [ p[] [text $ "Editing " <> ngrams]
175
              , renderNgramsTree { ngramsTable, ngrams, ngramsStyle: [], ngramsClick, ngramsEdit }
176 177 178 179
              , 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" ]
180 181
                [ table [ className "table able" ]
                  [ thead [ className "tableHeader"] [props.tableHead]
182 183 184 185 186 187 188 189
                  , tbody [] props.tableBody
                  ]
                ]
          ]
        ]
      ]
    ]
  ]
190 191 192 193
  where
    setPageParams f = loaderDispatch $ Loader.SetPath $ f pageParams
    setSearchQuery    x = setPageParams $ _ { searchQuery = x }
    setTermListFilter x = setPageParams $ _ { termListFilter = x }
194
    setTermSizeFilter x = setPageParams $ _ { termSizeFilter = x }
195 196 197 198 199

toggleMap :: forall a. a -> Maybe a -> Maybe a
toggleMap _ (Just _) = Nothing
toggleMap b Nothing  = Just b

200
ngramsTableSpec :: Spec State LoadedNgramsTableProps Action
201 202 203 204 205
ngramsTableSpec = simpleSpec performAction render
  where
    setParentResetChildren :: Maybe NgramsTerm -> State -> State
    setParentResetChildren p = _ { ngramsParent = p, ngramsChildren = mempty }

206
    performAction :: PerformAction State LoadedNgramsTableProps Action
207 208 209 210
    performAction (SetParentResetChildren p) _ _ =
      modifyState_ $ setParentResetChildren p
    performAction (ToggleChild b c) _ _ =
      modifyState_ $ _ngramsChildren <<< at c %~ toggleMap b
211 212
    performAction Refresh {path: {nodeId, listIds, tabType}} {ngramsVersion} = do
        commitPatch {nodeId, listIds, tabType} (Versioned {version: ngramsVersion, data: mempty})
Nicolas Pouillard's avatar
Nicolas Pouillard committed
213 214
    performAction (SetTermListItem n pl) {path: {nodeId, listIds, tabType}} {ngramsVersion} =
        commitPatch {nodeId, listIds, tabType} (Versioned {version: ngramsVersion, data: pt})
215
      where
216
        listId = Just 10 -- List.head listIds
217 218 219 220 221
        pe = NgramsPatch { patch_list: pl, patch_children: mempty }
        pt = PatchMap $ Map.singleton n pe
    performAction AddTermChildren _ {ngramsParent: Nothing} =
        -- impossible but harmless
        pure unit
Nicolas Pouillard's avatar
Nicolas Pouillard committed
222
    performAction AddTermChildren {path: {nodeId, listIds, tabType}}
223 224
                  { ngramsParent: Just parent
                  , ngramsChildren
225
                  , ngramsVersion
226 227
                  } = do
        modifyState_ $ setParentResetChildren Nothing
Nicolas Pouillard's avatar
Nicolas Pouillard committed
228
        commitPatch {nodeId, listIds, tabType} (Versioned {version: ngramsVersion, data: pt})
229
      where
230
        listId = Just 10 -- List.head listIds
231 232 233 234 235
        pc = patchSetFromMap ngramsChildren
        pe = NgramsPatch { patch_list: mempty, patch_children: pc }
        pt = PatchMap $ Map.fromFoldable [Tuple parent pe]
        -- TODO ROOT-UPDATE
        -- patch the root of the child to be equal to the root of the parent.
236
    performAction (AddNewNgram ngram) {path: params} _ =
237
      lift $ addNewNgram ngram Nothing params
238

239
    render :: Render State LoadedNgramsTableProps Action
240
    render dispatch { path: pageParams
241
                    , loaded: Versioned { data: initTable }
242
                    , dispatch: loaderDispatch }
243
                    { ngramsTablePatch, ngramsParent, ngramsChildren }
244
                    _reactChildren =
245 246 247 248
      [ autoUpdateElt { duration: 3000
                      , effect:   dispatch Refresh
                      }
      , T.tableElt
249
          { rows
250 251
          , setParams
          , container: tableContainer {pageParams, loaderDispatch, dispatch, ngramsParent, ngramsChildren, ngramsTable}
252 253 254 255 256
          , colNames:
              T.ColumnName <$>
              [ "Graph"
              , "Stop"
              , "Terms"
257
              , "Score (Occurrences)" -- see convOrderBy
258 259 260 261 262
              ]
          , totalRecords: 47361 -- TODO
          }
      ]
          where
263 264
            setParams params =
              loaderDispatch $ Loader.SetPath $ pageParams {params = params}
265
            ngramsTable = applyNgramsTablePatch ngramsTablePatch initTable
266 267 268 269 270 271 272 273 274 275
            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)
276 277 278 279 280 281 282 283 284 285 286 287 288 289

            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
290
              || -- Unless they are scheduled to be removed.
291
                 ngramsChildren ^. at ngrams == Just false
292
            convertRow (Tuple ngrams ngramsElement) =
293
              { row: renderNgramsItem { ngramsTable, ngrams, ngramsParent, ngramsElement, dispatch}
294 295 296
              , delete: false
              }

297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
ngramsTableClass :: Loader.InnerClass PageParams VersionedNgramsTable
ngramsTableClass = createClass "NgramsTable" ngramsTableSpec initialState

type MainNgramsTableProps =
  Loader.InnerProps Int { defaultListId :: Int }
                        ( tabType :: TabType )

mainNgramsTableSpec :: Spec {} MainNgramsTableProps Void
mainNgramsTableSpec = simpleSpec defaultPerformAction render
  where
    render :: Render {} MainNgramsTableProps Void
    render _ {path: nodeId, loaded: {defaultListId}, tabType} _ _ =
      [ ngramsLoader
          { path: initialPageParams nodeId [defaultListId] tabType
          , component: ngramsTableClass
          } ]

314 315 316
type NgramsDepth = {ngrams :: NgramsTerm, depth :: Int}
type NgramsClick = NgramsDepth -> Maybe (Effect Unit)

317 318
tree :: { ngramsTable :: NgramsTable
        , ngramsStyle :: Array DOM.Props
319
        , ngramsEdit  :: NgramsClick
320 321
        , ngramsClick :: NgramsClick
        } -> NgramsDepth -> ReactElement
322
tree params@{ngramsTable, ngramsStyle, ngramsEdit, ngramsClick} nd@{ngrams} =
323
  li [ style {width : "100%"} ]
324
    ([ i icon []
325
     , tag [text $ " " <> ngrams]
326 327 328
     ] <> maybe [] edit (ngramsEdit nd) <>
     [ forest cs
     ])
329 330
  where
    tag =
331
      case ngramsClick nd of
332 333 334 335
        Just effect ->
          a (ngramsStyle <> [onClick $ const effect])
        Nothing ->
          span ngramsStyle
336 337 338
    edit effect = [ text " "
                  , i [ className "glyphicon glyphicon-pencil"
                      , onClick $ const effect ] [] ]
339
    leaf = List.null cs
340
    icon = gray <> [className $ "glyphicon glyphicon-chevron-" <> if open then "down" else "right"]
341 342
    open = not leaf || false {- TODO -}
    gray = if leaf then [style {color: "#adb5bd"}] else []
343
    cs   = ngramsTable ^.. ix ngrams <<< _NgramsElement <<< _children <<< folded
344

345 346 347
    forest =
      let depth = nd.depth + 1 in
      ul [] <<< map (\ngrams -> tree params {depth, ngrams}) <<< List.toUnfoldable
348

349 350 351 352 353 354 355 356
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)

357 358 359
renderNgramsTree :: { ngrams      :: NgramsTerm
                    , ngramsTable :: NgramsTable
                    , ngramsStyle :: Array DOM.Props
360
                    , ngramsClick :: NgramsClick
361
                    , ngramsEdit  :: NgramsClick
362
                    } -> ReactElement
363
renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit } =
364
  ul [] [
365
    span [className "tree"] [tree {ngramsTable, ngramsStyle, ngramsClick, ngramsEdit} {ngrams, depth: 0}]
366 367 368 369
  ]

renderNgramsItem :: { ngrams :: NgramsTerm
                    , ngramsTable :: NgramsTable
370
                    , ngramsElement :: NgramsElement
371 372 373
                    , ngramsParent :: Maybe NgramsTerm
                    , dispatch :: Action -> Effect Unit
                    } -> Array ReactElement
374
renderNgramsItem { ngramsTable, ngrams, ngramsElement, ngramsParent, dispatch } =
375 376 377
  [ checkbox GraphTerm
  , checkbox StopTerm
  , if ngramsParent == Nothing
378
    then renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit }
379 380
    else
      a [onClick $ const $ dispatch $ ToggleChild true ngrams]
381
        [ i [className "glyphicon glyphicon-plus"] []
382 383
        , span ngramsStyle [text $ " " <> ngrams]
        ]
384
  , text $ show (ngramsElement ^. _NgramsElement <<< _occurrences)
385 386
  ]
  where
387
    termList    = ngramsElement ^. _NgramsElement <<< _list
388
    ngramsStyle = [termStyle termList]
389 390
    ngramsEdit  = Just <<< dispatch <<< SetParentResetChildren <<< Just <<< view _ngrams
    ngramsClick = Just <<< cycleTermListItem <<< view _ngrams
391 392 393 394 395 396 397 398 399
    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"
400
        , onChange $ const $ setTermList (replace termList termList'') ngrams
401 402
        ]

403 404 405 406
    setTermList Keep                    _ = pure unit
    setTermList rep@(Replace {old,new}) n = dispatch $ SetTermListItem n rep

    cycleTermListItem = setTermList (replace termList (nextTermList termList))
407 408 409 410 411 412

termStyle :: TermList -> DOM.Props
termStyle GraphTerm     = style {color: "green"}
termStyle StopTerm      = style {color: "red", textDecoration : "line-through"}
termStyle CandidateTerm = style {color: "black"}

413 414 415 416 417
nextTermList :: TermList -> TermList
nextTermList GraphTerm     = StopTerm
nextTermList StopTerm      = CandidateTerm
nextTermList CandidateTerm = GraphTerm

418 419 420 421 422 423 424
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