NgramsTable.purs 22.8 KB
Newer Older
1 2 3 4
module Gargantext.Components.NgramsTable
  ( MainNgramsTableProps
  , mainNgramsTable
  ) where
5

6
import Prelude
7 8
  ( class Show, Unit, bind, const, discard, identity, map, mempty, not
  , pure, show, unit, (#), ($), (&&), (+), (/=), (<$>), (<<<), (<>), (=<<)
9
  , (==), (||), otherwise )
10
import Data.Array as A
11 12
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (Lens', to, view, (%~), (.~), (^.), (^..), (^?))
13
import Data.Lens.Common (_Just)
14 15 16
import Data.Lens.At (at)
import Data.Lens.Index (ix)
import Data.Lens.Fold (folded)
17 18 19 20
import Data.Lens.Record (prop)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
21
import Data.Maybe (Maybe(..), maybe, isNothing)
22
import Data.Monoid.Additive (Additive(..))
23
import Data.Ord.Down (Down(..))
24 25
import Data.Set (Set)
import Data.Set as Set
26
import Data.Symbol (SProxy(..))
27
import Data.Tuple (Tuple(..), snd)
28
import Data.Tuple.Nested ((/\))
29
import Effect (Effect)
30 31
import Reactix as R
import Reactix.DOM.HTML as H
32
import React (ReactClass, ReactElement, Children)
33 34
import React.DOM (a, i, input, li, span, text, ul)
import React.DOM.Props (_type, checked, className, onChange, onClick, style)
35
import React.DOM.Props as DOM
36 37
import Thermite as Thermite
import Thermite (modifyState_)
38 39 40
import Gargantext.Types
  ( CTabNgramType, OrderBy(..), TabType, TermList(..), readTermList
  , readTermSize, termLists, termSizes)
41
import Gargantext.Components.AutoUpdate (autoUpdateElt)
42
import Gargantext.Components.NgramsTable.Core
43
  ( CoreState, NgramsElement(..), NgramsPatch(..), NgramsTablePatch, _PatchMap
44
  , NgramsTable, NgramsTerm, PageParams, Replace, Versioned(..)
45
  , VersionedNgramsTable, _NgramsElement, _NgramsTable, _children
46 47 48
  , _list, _ngrams, _occurrences, _root, addNewNgram, applyNgramsPatches
  , applyPatchSet, commitPatch, syncPatches, convOrderBy, initialPageParams, loadNgramsTable
  , patchSetFromMap, replace, singletonNgramsTablePatch
49
  , normNgram, ngramsTermText, fromNgramsPatches, PatchMap(..), rootsOf )
50
import Gargantext.Components.Loader (loader)
51
import Gargantext.Components.Table as T
52
import Gargantext.Sessions (Session)
53
import Gargantext.Utils.Reactix as R2
54

55 56
import Unsafe.Coerce (unsafeCoerce)

57
type State =
58 59
  CoreState
  ( ngramsParent     :: Maybe NgramsTerm -- Nothing means we are not currently grouping terms
60 61 62 63 64
  , 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.
65 66 67 68
  , ngramsSelection  :: Set NgramsTerm
                     -- ^ The set of selected checkboxes of the first column.
  , ngramsSelectAll  :: Boolean
                     -- ^ The checkbox to select all the checkboxes of the first column.
69
  )
70

71
_ngramsChildren :: forall row. Lens' { ngramsChildren :: Map NgramsTerm Boolean | row } (Map NgramsTerm Boolean)
72 73
_ngramsChildren = prop (SProxy :: SProxy "ngramsChildren")

74 75 76 77 78 79
_ngramsSelectAll :: forall row. Lens' { ngramsSelectAll :: Boolean | row } Boolean
_ngramsSelectAll = prop (SProxy :: SProxy "ngramsSelectAll")

_ngramsSelection :: forall row. Lens' { ngramsSelection :: Set NgramsTerm | row } (Set NgramsTerm)
_ngramsSelection = prop (SProxy :: SProxy "ngramsSelection")

80 81
initialState :: VersionedNgramsTable -> State
initialState (Versioned {version}) =
82 83 84
  { ngramsLocalPatch: mempty
  , ngramsStagePatch: mempty
  , ngramsValidPatch: mempty
85
  , ngramsVersion:    version
86 87
  , ngramsParent:     Nothing
  , ngramsChildren:   mempty
88 89
  , ngramsSelectAll:  false
  , ngramsSelection:  mempty
90 91 92
  }

data Action
93
  = CommitPatch NgramsTablePatch
94 95 96 97 98 99
  | 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.
100
  | AddTermChildren
101
  | Synchronize
102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
  | ToggleSelect NgramsTerm
  -- ^ Toggles the NgramsTerm in the `Set` `ngramsSelection`.
  | ToggleSelectAll

setTermListA :: NgramsTerm -> Replace TermList -> Action
setTermListA n patch_list =
  CommitPatch $
    singletonNgramsTablePatch n $
    NgramsPatch { patch_list, patch_children: mempty }

setTermListSetA :: NgramsTable -> Set NgramsTerm -> TermList -> Action
setTermListSetA ngramsTable ns new_list =
  CommitPatch $ fromNgramsPatches $ PatchMap $ mapWithIndex f $ toMap ns
  where
    f :: NgramsTerm -> Unit -> NgramsPatch
    f n unit = NgramsPatch { patch_list, patch_children: mempty }
      where
        cur_list = ngramsTable ^? at n <<< _Just <<< _NgramsElement <<< _list
120
        patch_list = maybe mempty (\c -> replace c new_list) cur_list
121 122 123 124 125 126 127
    toMap :: forall a. Set a -> Map a Unit
    toMap = unsafeCoerce
    -- TODO https://github.com/purescript/purescript-ordered-collections/pull/21
    -- toMap = Map.fromFoldable

addNewNgramA :: NgramsTerm -> Action
addNewNgramA ngram = CommitPatch $ addNewNgram ngram CandidateTerm
128 129 130

type Dispatch = Action -> Effect Unit

131 132 133 134 135 136 137
tableContainer :: { path            :: R.State PageParams
                  , dispatch        :: Dispatch
                  , ngramsParent    :: Maybe NgramsTerm
                  , ngramsChildren  :: Map NgramsTerm Boolean
                  , ngramsSelection :: Set NgramsTerm
                  , ngramsTable     :: NgramsTable
                  , tabNgramType    :: CTabNgramType
138
                  , ngramsSelectAll :: Boolean
139
                  }
140
               -> Record T.TableContainerProps -> R.Element
141
tableContainer { path: {searchQuery, termListFilter, termSizeFilter} /\ setPath
142 143 144
               , dispatch
               , ngramsParent
               , ngramsChildren
145
               , ngramsSelection
146
               , ngramsTable: ngramsTableCache
147
               , tabNgramType
148
               , ngramsSelectAll
149
               } props =
150 151
  H.div {className: "container-fluid"}
  [ H.div {className: "jumbotron1"}
152
    [ R2.row
153 154 155 156 157
      [ H.div {className: "panel panel-default"}
        [ H.div {className: "panel-heading"}
          [ H.h2 {className: "panel-title", style: {textAlign : "center"}}
            [ H.span {className: "glyphicon glyphicon-hand-down"} []
            , H.text "Extracted Terms"
158
            ]
159
          , R2.row
160 161 162 163 164
            [ H.div {className: "col-md-3", style: {marginTop: "6px"}}
              [ H.input { className: "form-control"
                        , name: "search"
                        , placeholder: "Search"
                        , type: "value"
165
                        , value: searchQuery
166
                        , on: {input: setSearchQuery <<< R2.unsafeEventValue}}
167
              , H.div {} (
168
                   if A.null props.tableBody && searchQuery /= "" then [
169
                     H.button { className: "btn btn-primary"
170 171
                              , on: {click: const $ dispatch $ addNewNgramA $ normNgram tabNgramType searchQuery}
                              }
172
                     [ H.text ("Add " <> searchQuery) ]
173 174 175 176 177
                     ] else [])]
            , H.div {className: "col-md-2", style: {marginTop : "6px"}}
              [ H.li {className: " list-group-item"}
                [ R2.select { id: "picklistmenu"
                            , className: "form-control custom-select"
178
                            , value: (maybe "" show termListFilter)
179
                            , on: {change: setTermListFilter <<< readTermList <<< R2.unsafeEventValue}}
180 181 182 183 184
                  (map optps1 termLists)]]
            , H.div {className: "col-md-2", style: {marginTop : "6px"}}
              [ H.li {className: "list-group-item"}
                [ R2.select {id: "picktermtype"
                            , className: "form-control custom-select"
185
                            , value: (maybe "" show termSizeFilter)
186
                            , on: {change: setTermSizeFilter <<< readTermSize <<< R2.unsafeEventValue}}
187 188 189 190 191 192
                    (map optps1 termSizes)]]
            , H.div {className: "col-md-4", style: {marginTop : "6px", marginBottom : "1px"}}
              [ H.li {className: " list-group-item"}
                [ props.pageSizeDescription
                , props.pageSizeControl
                , H.text " items / "
193 194
                , props.paginationLinks]]
            ]]
195 196
        , H.div {}
          (maybe [] (\ngrams ->
197 198 199 200 201 202 203
              let
                ngramsTable =
                  ngramsTableCache # at ngrams
                                 <<< _Just
                                 <<< _NgramsElement
                                 <<< _children
                                 %~ applyPatchSet (patchSetFromMap ngramsChildren)
204 205 206
                ngramsClick {depth: 1, ngrams: child} =
                  Just $ dispatch $ ToggleChild false child
                ngramsClick _ = Nothing
207
                ngramsEdit _ = Nothing
208
              in
209
              [ H.p {} [H.text $ "Editing " <> ngramsTermText ngrams]
210
              , R2.buff $ renderNgramsTree { ngramsTable, ngrams, ngramsStyle: [], ngramsClick, ngramsEdit }
211
              , H.button {className: "btn btn-primary", on: {click: (const $ dispatch AddTermChildren)}} [H.text "Save"]
212
              , H.button {className: "btn btn-secondary", on: {click: (const $ dispatch $ SetParentResetChildren Nothing)}} [H.text "Cancel"]
213
              ]) ngramsParent)
214 215 216
          , H.div {id: "terms_table", className: "panel-body"}
            [ H.table {className: "table able"}
              [ H.thead {className: "tableHeader"} [props.tableHead]
217 218
              , H.tbody {} props.tableBody]]

219
          , if ngramsSelectAll then H.li {className: " list-group-item"}
220 221 222 223 224 225 226 227 228
                [ H.button { className: "btn btn-primary"
                           , on: {click: const $ setSelection GraphTerm }
                           }
                  [ H.text "Map" ]
                , H.button { className: "btn btn-primary"
                           , on: {click: const $ setSelection StopTerm }
                           }
                  [ H.text "Stop" ]
                  ]
229
                else H.div {}[]
230 231 232 233
                ]
              ]
            ]
          ]
234
  where
235 236 237 238
    -- WHY setPath     f = origSetPageParams (const $ f path)
    setSearchQuery    x = setPath $ _ { searchQuery = x }
    setTermListFilter x = setPath $ _ { termListFilter = x }
    setTermSizeFilter x = setPath $ _ { termSizeFilter = x }
239
    setSelection = dispatch <<< setTermListSetA ngramsTableCache ngramsSelection
240

241 242 243
toggleMaybe :: forall a. a -> Maybe a -> Maybe a
toggleMaybe _ (Just _) = Nothing
toggleMaybe b Nothing  = Just b
244

245
-- NEXT
246 247 248
data Action'
  = SetParentResetChildren' (Maybe NgramsTerm)
  | ToggleChild' (Maybe NgramsTerm) NgramsTerm
249
  | Synchronize'
250

251
-- NEXT
252
type Props =
253
  ( path         :: R.State PageParams
254
  , versioned    :: VersionedNgramsTable )
255

256
-- NEXT
257 258
loadedNgramsTable :: Record Props -> R.Element
loadedNgramsTable props = R.createElement loadedNgramsTableCpt props []
259

260
-- NEXT
261 262
loadedNgramsTableCpt :: R.Component Props
loadedNgramsTableCpt = R.hooksComponent "G.C.NgramsTable.loadedNgramsTable" cpt
263 264 265 266 267
  where
    cpt {versioned} _ = do
      state <- useNgramsReducer (initialState versioned)
      pure $ R.fragment []

268 269 270 271 272 273
    useNgramsReducer :: State -> R.Hooks (R.Reducer State Action')
    useNgramsReducer init = R2.useReductor' performNgramsAction init

    performNgramsAction :: Action' -> State -> Effect State
    performNgramsAction (SetParentResetChildren' term) = pure -- TODO
    performNgramsAction (ToggleChild' b c) = pure -- TODO
274
    performNgramsAction Synchronize' = pure -- TODO
275

276 277 278 279 280 281 282 283
type LoadedNgramsTableProps =
  ( tabNgramType :: CTabNgramType
  , path         :: R.State PageParams
  , versioned    :: VersionedNgramsTable
  )

loadedNgramsTableSpec :: Thermite.Spec State (Record LoadedNgramsTableProps) Action
loadedNgramsTableSpec = Thermite.simpleSpec performAction render
284 285 286 287
  where
    setParentResetChildren :: Maybe NgramsTerm -> State -> State
    setParentResetChildren p = _ { ngramsParent = p, ngramsChildren = mempty }

288
    performAction :: Thermite.PerformAction State (Record LoadedNgramsTableProps) Action
289 290 291
    performAction (SetParentResetChildren p) _ _ =
      modifyState_ $ setParentResetChildren p
    performAction (ToggleChild b c) _ _ =
292 293 294 295 296 297 298
      modifyState_ $ _ngramsChildren <<< at c %~ toggleMaybe b
    performAction (ToggleSelect c) _ _ =
      modifyState_ $ _ngramsSelection <<< at c %~ toggleMaybe unit
    performAction ToggleSelectAll _ { ngramsSelectAll: true } =
      modifyState_ $ (_ngramsSelection .~ mempty)
                 <<< (_ngramsSelectAll .~ false)
    performAction ToggleSelectAll { versioned: Versioned { data: initTable } }
299
                                  state =
300
      let
301
        ngramsTable = applyNgramsPatches state initTable
302 303 304 305
        roots = rootsOf ngramsTable
      in
      modifyState_ $ (_ngramsSelection .~ roots)
                 <<< (_ngramsSelectAll .~ true)
306 307 308 309
    performAction Synchronize {path: path /\ _} state = do
      syncPatches path state
    performAction (CommitPatch pt) _ {ngramsVersion} =
      commitPatch (Versioned {version: ngramsVersion, data: pt})
310

311 312 313
    performAction AddTermChildren _ {ngramsParent: Nothing} =
        -- impossible but harmless
        pure unit
314
    performAction AddTermChildren _
315 316
                  { ngramsParent: Just parent
                  , ngramsChildren
317
                  , ngramsVersion
318 319
                  } = do
        modifyState_ $ setParentResetChildren Nothing
320
        commitPatch (Versioned {version: ngramsVersion, data: pt})
321 322 323
      where
        pc = patchSetFromMap ngramsChildren
        pe = NgramsPatch { patch_list: mempty, patch_children: pc }
324
        pt = singletonNgramsTablePatch parent pe
325

326
    render :: Thermite.Render State (Record LoadedNgramsTableProps) Action
327 328 329
    render dispatch { path: path@({scoreType, params} /\ setPath)
                    , versioned: Versioned { data: initTable }
                    , tabNgramType }
330 331
                    state@{ ngramsParent, ngramsChildren, ngramsLocalPatch
                          , ngramsSelection, ngramsSelectAll }
332
                    _reactChildren =
333
      [ autoUpdateElt { duration: 3000, effect: dispatch Synchronize }
334
      , R2.scuff $ T.table { params: params /\ setParams -- TODO-LENS
335 336
                           , rows, container, colNames, wrapColElts, totalRecords
                           }
337
      ]
338 339
      where
        totalRecords = 47361 -- TODO
340 341 342 343 344 345 346 347 348 349 350 351
        colNames = T.ColumnName <$> ["Select", "Map", "Stop", "Terms", "Score"] -- see convOrderBy
        selected =
          input
            [ _type "checkbox"
            , className "checkbox"
            , checked ngramsSelectAll
            , onChange $ const $ dispatch $ ToggleSelectAll
            ]
        -- This is used to *decorate* the Select header with the checkbox.
        wrapColElts (T.ColumnName "Select") = const [R2.buff selected]
        wrapColElts (T.ColumnName "Score")  = (_ <> [H.text ("(" <> show scoreType <> ")")])
        wrapColElts _                       = identity
352
        container = tableContainer {path, dispatch, ngramsParent, ngramsChildren, ngramsSelection, ngramsTable, tabNgramType, ngramsSelectAll}
353
        setParams f = setPath $ \p@{params: ps} -> p {params = f ps}
354
        ngramsTable = applyNgramsPatches state initTable
355
        orderWith =
356
          case convOrderBy <$> params.orderBy of
357 358 359 360 361 362 363 364 365
            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)

366
        ngramsParentRoot :: Maybe NgramsTerm
367
        ngramsParentRoot =
368
          (\np -> ngramsTable ^? at np <<< _Just <<< _NgramsElement <<< _root <<< _Just) =<< ngramsParent
369 370 371 372 373 374 375 376 377 378 379 380 381

        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) =
382
          { row: R2.buff <$> renderNgramsItem { ngramsTable, ngrams,
383
                                                ngramsLocalPatch,
384 385
                                                ngramsParent, ngramsElement,
                                                ngramsSelection, dispatch }
386 387 388
          , delete: false
          }

389 390 391
loadedNgramsTableClass :: ReactClass { children :: Children | LoadedNgramsTableProps }
loadedNgramsTableClass = Thermite.createClass "LoadedNgramsNgramsTable"
  loadedNgramsTableSpec (\{versioned} -> initialState versioned)
392

393 394
loadedNgramsTable' :: Record LoadedNgramsTableProps -> R.Element
loadedNgramsTable' props = R2.createElement' (loadedNgramsTableClass) props []
395 396

type MainNgramsTableProps =
397
  ( nodeId        :: Int
398 399 400
    -- ^ This node can be a corpus or contact.
  , defaultListId :: Int
  , tabType       :: TabType
401
  , session       :: Session
402 403
  , tabNgramType  :: CTabNgramType
  )
404

405 406
mainNgramsTable :: Record MainNgramsTableProps -> R.Element
mainNgramsTable props = R.createElement mainNgramsTableCpt props []
407

408 409 410
mainNgramsTableCpt :: R.Component MainNgramsTableProps
mainNgramsTableCpt = R.hooksComponent "MainNgramsTable" cpt
  where
411
    cpt {nodeId, defaultListId, tabType, session, tabNgramType} _ = do
412 413 414
      path /\ setPath <- R.useState' $ initialPageParams session nodeId [defaultListId] tabType
      let paint versioned = loadedNgramsTable' {tabNgramType, path: path /\ setPath, versioned}
      pure $ loader path loadNgramsTable paint
415

416 417 418
type NgramsDepth = {ngrams :: NgramsTerm, depth :: Int}
type NgramsClick = NgramsDepth -> Maybe (Effect Unit)

419 420
tree :: { ngramsTable :: NgramsTable
        , ngramsStyle :: Array DOM.Props
421
        , ngramsEdit  :: NgramsClick
422 423
        , ngramsClick :: NgramsClick
        } -> NgramsDepth -> ReactElement
424
tree params@{ngramsTable, ngramsStyle, ngramsEdit, ngramsClick} nd =
425
  li [ style {width : "100%"} ]
426
    ([ i icon []
427
     , tag [text $ " " <> ngramsTermText nd.ngrams]
428 429 430
     ] <> maybe [] edit (ngramsEdit nd) <>
     [ forest cs
     ])
431 432
  where
    tag =
433
      case ngramsClick nd of
434 435 436 437
        Just effect ->
          a (ngramsStyle <> [onClick $ const effect])
        Nothing ->
          span ngramsStyle
438 439 440
    edit effect = [ text " "
                  , i [ className "glyphicon glyphicon-pencil"
                      , onClick $ const effect ] [] ]
441
    leaf = List.null cs
442
    icon = gray <> [className $ "glyphicon glyphicon-chevron-" <> if open then "down" else "right"]
443 444
    open = not leaf || false {- TODO -}
    gray = if leaf then [style {color: "#adb5bd"}] else []
445
    cs   = ngramsTable ^.. ix nd.ngrams <<< _NgramsElement <<< _children <<< folded
446

447 448 449
    forest =
      let depth = nd.depth + 1 in
      ul [] <<< map (\ngrams -> tree params {depth, ngrams}) <<< List.toUnfoldable
450

451 452 453 454 455 456 457 458
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)

459 460 461
renderNgramsTree :: { ngrams      :: NgramsTerm
                    , ngramsTable :: NgramsTable
                    , ngramsStyle :: Array DOM.Props
462
                    , ngramsClick :: NgramsClick
463
                    , ngramsEdit  :: NgramsClick
464
                    } -> ReactElement
465
renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit } =
466
  ul [] [
467
    span [className "tree"] [tree {ngramsTable, ngramsStyle, ngramsClick, ngramsEdit} {ngrams, depth: 0}]
468 469 470 471
  ]

renderNgramsItem :: { ngrams :: NgramsTerm
                    , ngramsTable :: NgramsTable
472
                    , ngramsLocalPatch :: NgramsTablePatch
473
                    , ngramsElement :: NgramsElement
474
                    , ngramsParent :: Maybe NgramsTerm
475
                    , ngramsSelection :: Set NgramsTerm
476 477
                    , dispatch :: Action -> Effect Unit
                    } -> Array ReactElement
478
renderNgramsItem { ngramsTable, ngrams, ngramsElement, ngramsParent
479
                 , ngramsSelection, ngramsLocalPatch, dispatch } =
480 481
  [ selected
  , checkbox GraphTerm
482 483
  , checkbox StopTerm
  , if ngramsParent == Nothing
484
    then renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit }
485 486
    else
      a [onClick $ const $ dispatch $ ToggleChild true ngrams]
487
        [ i [className "glyphicon glyphicon-plus"] []
488
        , span ngramsStyle [text $ " " <> ngramsTermText ngrams]
489
        ]
490
  , text $ show (ngramsElement ^. _NgramsElement <<< _occurrences)
491 492
  ]
  where
493
    termList    = ngramsElement ^. _NgramsElement <<< _list
494
    ngramsStyle = [termStyle termList ngramsOpacity]
495
    ngramsEdit  = Just <<< dispatch <<< SetParentResetChildren <<< Just <<< view _ngrams
496 497 498 499 500 501 502 503
    ngramsClick = Just <<< dispatch <<< cycleTermListItem <<< view _ngrams
    selected    =
      input
        [ _type "checkbox"
        , className "checkbox"
        , checked $ Set.member ngrams ngramsSelection
        , onChange $ const $ dispatch $ ToggleSelect ngrams
        ]
504 505 506 507 508 509 510 511
    checkbox termList' =
      let chkd = termList == termList'
          termList'' = if chkd then CandidateTerm else termList'
      in
      input
        [ _type "checkbox"
        , className "checkbox"
        , checked chkd
512 513
        , onChange $ const $ dispatch $
            setTermListA ngrams (replace termList termList'')
514
        ]
515 516 517 518
    ngramsOpacity
      | isNothing (ngramsLocalPatch.ngramsPatches ^. _PatchMap <<< at ngrams) = 1.0
      -- ^ TODO here we do not look at ngramsNewElems, shall we?
      | otherwise                                                             = 0.5
519

520
    cycleTermListItem n = setTermListA n (replace termList (nextTermList termList))
521

522 523 524 525
termStyle :: TermList -> Number -> DOM.Props
termStyle GraphTerm     opacity = style {color: "green", opacity}
termStyle StopTerm      opacity = style {color: "red",   opacity, textDecoration: "line-through"}
termStyle CandidateTerm opacity = style {color: "black", opacity}
526

527 528 529 530 531
nextTermList :: TermList -> TermList
nextTermList GraphTerm     = StopTerm
nextTermList StopTerm      = CandidateTerm
nextTermList CandidateTerm = GraphTerm

532 533 534
optps1 :: forall a. Show a => { desc :: String, mval :: Maybe a } -> R.Element
optps1 { desc, mval } = H.option {value} [H.text desc]
  where value = maybe "" show mval