NgramsTable.purs

module Gargantext.Components.NgramsTable
  ( MainNgramsTableProps
  , mainNgramsTable
  ) where

import Data.Array as A
import Data.FunctorWithIndex (mapWithIndex)
import Data.Lens (Lens', to, (%~), (.~), (^.), (^?))
import Data.Lens.At (at)
import Data.Lens.Common (_Just)
import Data.Lens.Fold (folded)
import Data.Lens.Index (ix)
import Data.Lens.Record (prop)
import Data.List (List, filter, length) as L
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Monoid.Additive (Additive(..))
import Data.Ord.Down (Down(..))
import Data.Set (Set)
import Data.Set as Set
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(..), fst, snd)
import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Effect.Aff (Aff)
import Gargantext.Components.AutoUpdate (autoUpdateElt)
import Gargantext.Components.NgramsTable.Components as NTC
import Gargantext.Components.NgramsTable.Core
import Gargantext.Components.NgramsTable.Loader (useLoaderWithCacheAPI)
import Gargantext.Components.Table as T
import Gargantext.Prelude (class Show, Unit, bind, const, discard, identity, map, mempty, not, pure, show, unit, (#), ($), (&&), (/=), (<$>), (<<<), (<>), (=<<), (==), (||), read)
import Gargantext.Routes (SessionRoute(..)) as R
import Gargantext.Sessions (Session, get)
import Gargantext.Types (CTabNgramType, OrderBy(..), SearchQuery, TabType, TermList(..), TermSize, termLists, termSizes)
import Gargantext.Utils (queryMatchesLabel, toggleSet)
import Gargantext.Utils.CacheAPI as GUC
import Gargantext.Utils.List (sortWith) as L
import Gargantext.Utils.Reactix as R2
import Reactix (Component, Element, State, createElement, fragment, hooksComponent, useState') as R
import Reactix.DOM.HTML as H
import Unsafe.Coerce (unsafeCoerce)

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.
  , ngramsSelection  :: Set NgramsTerm
                     -- ^ The set of selected checkboxes of the first column.
  )

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

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

initialState' :: VersionedNgramsTable -> State'
initialState' (Versioned {version}) =
  { ngramsChildren:   mempty
  , ngramsLocalPatch: mempty
  , ngramsParent:     Nothing
  , ngramsSelection:  mempty
  , ngramsStagePatch: mempty
  , ngramsValidPatch: mempty
  , ngramsVersion:    version
  }

type State =
  CoreState (
    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.
  , ngramsParent     :: Maybe NgramsTerm -- Nothing means we are not currently grouping terms
  , ngramsSelection  :: Set NgramsTerm
                     -- ^ The set of selected checkboxes of the first column.
  )

initialState :: VersionedNgramsTable -> State
initialState (Versioned {version}) = {
    ngramsChildren:   mempty
  , ngramsLocalPatch: mempty
  , ngramsParent:     Nothing
  , ngramsSelection:  mempty
  , ngramsStagePatch: mempty
  , ngramsValidPatch: mempty
  , ngramsVersion:    version
  }

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
        patch_list = maybe mempty (\c -> replace c new_list) cur_list
    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

type PreConversionRows = L.List (Tuple NgramsTerm NgramsElement)

type TableContainerProps =
  ( dispatch         :: Dispatch
  , ngramsChildren   :: Map NgramsTerm Boolean
  , ngramsParent     :: Maybe NgramsTerm
  , ngramsSelection  :: Set NgramsTerm
  , ngramsTable      :: NgramsTable
  , path             :: R.State PageParams
  , tabNgramType     :: CTabNgramType
  )

tableContainer :: Record TableContainerProps -> Record T.TableContainerProps -> R.Element
tableContainer p q = R.createElement (tableContainerCpt p) q []

tableContainerCpt :: Record TableContainerProps -> R.Component T.TableContainerProps
tableContainerCpt { dispatch
                  , ngramsChildren
                  , ngramsParent
                  , ngramsSelection
                  , ngramsTable: ngramsTableCache
                  , path: {searchQuery, termListFilter, termSizeFilter} /\ setPath
                  , tabNgramType
                  } = R.hooksComponent "G.C.NT.tableContainer" cpt
  where
    cpt props _ = do
      pure $ H.div {className: "container-fluid"} [
        H.div {className: "jumbotron1"}
        [ R2.row
          [ H.div {className: "panel panel-default"}
            [ H.div {className: "panel-heading"} [
              R2.row
              [ H.div {className: "col-md-2", style: {marginTop: "6px"}}
                [
                  if A.null props.tableBody && searchQuery /= "" then
                    H.li { className: "list-group-item" } [
                      H.button { className: "btn btn-primary"
                                , on: { click: const $ dispatch
                                      $ addNewNgramA
                                      $ normNgram tabNgramType searchQuery
                                      }
                                }
                      [ H.text ("Add " <> searchQuery) ]
                    ] else H.div {} []
                ]
              , H.div {className: "col-md-2", style: {marginTop : "6px"}}
                [ H.li {className: "list-group-item"}
                  [ R2.select { id: "picklistmenu"
                              , className: "form-control custom-select"
                              , defaultValue: (maybe "" show termListFilter)
                              , on: {change: setTermListFilter <<< read <<< R2.unsafeEventValue}}
                    (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"
                              , defaultValue: (maybe "" show termSizeFilter)
                              , on: {change: setTermSizeFilter <<< read <<< R2.unsafeEventValue}}
                    (map optps1 termSizes)]
                ]
              , H.div { className: "col-md-2", style: { marginTop: "6px" } } [
                  H.li {className: "list-group-item"} [
                     H.div { className: "form-inline" } [
                    H.div { className: "form-group" } [
                       props.pageSizeControl
                     , H.label {} [ H.text " items" ]
                    --   H.div { className: "col-md-6" } [ props.pageSizeControl ]
                    -- , H.div { className: "col-md-6" } [
                    --    ]
                    ]
                    ]
                  ]
                ]
              , H.div {className: "col-md-4", style: {marginTop : "6px", marginBottom : "1px"}} [
                   H.li {className: "list-group-item"} [
                        props.pageSizeDescription
                      , props.paginationLinks
                      ]
                   ]
              ]
              ]
            , editor
            , if (selectionsExist ngramsSelection) then
                H.li {className: "list-group-item"} [
                  selectButtons true
                ] else
                H.div {} []
            , H.div {id: "terms_table", className: "panel-body"}
              [ H.table {className: "table able"}
                [ H.thead {className: "tableHeader"} [props.tableHead]
                , H.tbody {} props.tableBody
                ]

              , H.li {className: "list-group-item"} [
                 H.div { className: "row" } [
                    H.div { className: "col-md-4" } [
                       selectButtons (selectionsExist ngramsSelection)
                      ]
                    , H.div { className: "col-md-4 col-md-offset-4" } [
                       props.paginationLinks
                      ]
                    ]
                 ]
              ]
            ]
          ]
        ]
      ]
    -- WHY setPath     f = origSetPageParams (const $ f path)
    setTermListFilter x = setPath $ _ { termListFilter = x }
    setTermSizeFilter x = setPath $ _ { termSizeFilter = x }
    setSelection = dispatch <<< setTermListSetA ngramsTableCache ngramsSelection

    editor = H.div {} $ maybe [] f ngramsParent
      where
        f ngrams = [ H.p {} [H.text $ "Editing " <> ngramsTermText ngrams]
                   , NTC.renderNgramsTree { ngramsTable
                                          , ngrams
                                          , ngramsStyle: []
                                          , ngramsClick
                                          , ngramsEdit
                                          }
                   , H.button { className: "btn btn-primary"
                              , on: {click: (const $ dispatch AddTermChildren)}
                              } [H.text "Save"]
                   , H.button { className: "btn btn-secondary"
                              , on: {click: (const $ dispatch $ SetParentResetChildren Nothing)}
                              } [H.text "Cancel"]
                   ]
          where
            ngramsTable = ngramsTableCache # at ngrams
                          <<< _Just
                          <<< _NgramsElement
                          <<< _children
                          %~ applyPatchSet (patchSetFromMap ngramsChildren)
            ngramsClick {depth: 1, ngrams: child} = Just $ dispatch $ ToggleChild false child
            ngramsClick _ = Nothing
            ngramsEdit  _ = Nothing

    selectionsExist :: Set NgramsTerm -> Boolean
    selectionsExist = not <<< Set.isEmpty

    selectButtons false = H.div {} []
    selectButtons true =
      H.div {} [
        H.button { className: "btn btn-primary"
                , on: { click: const $ setSelection MapTerm }
                } [ H.text "Map" ]
        , H.button { className: "btn btn-primary"
                  , on: { click: const $ setSelection StopTerm }
                  } [ H.text "Stop" ]
        , H.button { className: "btn btn-primary"
                  , on: { click: const $ setSelection CandidateTerm }
                  } [ H.text "Candidate" ]
      ]

-- NEXT
type Props =
  ( path         :: R.State PageParams
  , state        :: R.State State
  , tabNgramType :: CTabNgramType
  , versioned    :: VersionedNgramsTable
  , withAutoUpdate :: Boolean
  )

loadedNgramsTable :: Record Props -> R.Element
loadedNgramsTable p = R.createElement loadedNgramsTableCpt p []

loadedNgramsTableCpt :: R.Component Props
loadedNgramsTableCpt = R.hooksComponent "G.C.NT.loadedNgramsTable" cpt
  where
    cpt { path: path@(path'@{searchQuery, scoreType, params, termListFilter, termSizeFilter} /\ setPath)
        , state: (state@{ ngramsChildren
                        , ngramsLocalPatch
                        , ngramsParent
                        , ngramsSelection
                        , ngramsVersion } /\ setState)
        , tabNgramType
        , versioned: Versioned { data: initTable }
        , withAutoUpdate } _ = do

      pure $ R.fragment $
        autoUpdate <> resetSaveButtons <> [
          H.h4 {style: {textAlign : "center"}} [
              H.span {className: "glyphicon glyphicon-hand-down"} []
            , H.text "Extracted Terms"
            ]
        , search
        , T.table { colNames
                  , container: tableContainer { dispatch: performAction
                                              , ngramsChildren
                                              , ngramsParent
                                              , ngramsSelection
                                              , ngramsTable
                                              , path
                                              , tabNgramType
                                              }
                  , params: params /\ setParams -- TODO-LENS
                  , rows: filteredConvertedRows
                  , totalRecords
                  , wrapColElts: wrapColElts { allNgramsSelected
                                             , dispatch: performAction
                                             , ngramsSelection
                                             }
                  }
        ] <> resetSaveButtons
      where
        autoUpdate :: Array R.Element
        autoUpdate = if withAutoUpdate then [ R2.buff $ autoUpdateElt { duration: 5000, effect: performAction Synchronize } ] else []
        resetButton :: R.Element
        resetButton = H.button { className: "btn btn-primary"
                               , on: { click: \_ -> performAction ResetPatches } } [ H.text "Reset" ]
        saveButton :: R.Element
        saveButton = H.button { className: "btn btn-primary"
                              , on: { click: \_ -> performAction Synchronize }} [ H.text "Save" ]
        resetSaveButtons :: Array R.Element
        resetSaveButtons = if ngramsLocalPatch == mempty then [] else
          [ H.div {} [ resetButton, saveButton ] ]

        setParentResetChildren :: Maybe NgramsTerm -> State -> State
        setParentResetChildren p = _ { ngramsParent = p, ngramsChildren = mempty }

        performAction :: Action -> Effect Unit
        performAction (SetParentResetChildren p) =
          setState $ setParentResetChildren p
        performAction (ToggleChild b c) =
          setState $ \s@{ ngramsChildren: nc } -> s { ngramsChildren = newNC nc }
          where
            newNC nc = Map.alter (maybe (Just b) (const Nothing)) c nc
        performAction (ToggleSelect c) =
          setState $ \s@{ ngramsSelection: ns } -> s { ngramsSelection = toggleSet c ns }
        performAction ToggleSelectAll =
          setState toggler
          where
            toggler s =
              if allNgramsSelected then
                s { ngramsSelection = Set.empty :: Set NgramsTerm }
              else
                s { ngramsSelection = selectNgramsOnFirstPage filteredRows }
        performAction Synchronize = syncPatchesR path' (state /\ setState)
        performAction (CommitPatch pt) =
          commitPatchR (Versioned {version: ngramsVersion, data: pt}) (state /\ setState)
        performAction ResetPatches =
          setState $ \s -> s { ngramsLocalPatch = { ngramsNewElems: mempty, ngramsPatches: mempty } }
        performAction AddTermChildren =
          case ngramsParent of
            Nothing ->
              -- impossible but harmless
              pure unit
            Just parent -> do
              let pc = patchSetFromMap ngramsChildren
                  pe = NgramsPatch { patch_list: mempty, patch_children: pc }
                  pt = singletonNgramsTablePatch parent pe
              setState $ setParentResetChildren Nothing
              commitPatchR (Versioned {version: ngramsVersion, data: pt}) (state /\ setState)

        totalRecords = L.length rows
        filteredConvertedRows :: T.Rows
        filteredConvertedRows = convertRow <$> filteredRows
        filteredRows :: PreConversionRows
        filteredRows = T.filterRows { params } rows
        rows :: PreConversionRows
        rows = orderWith (
          addOccT <$> (
             L.filter rowsFilterT $ Map.toUnfoldable (ngramsTable ^. _NgramsTable)
             )
          )
        rowsFilter :: NgramsElement -> Boolean
        rowsFilter = displayRow state searchQuery ngramsTable ngramsParentRoot termListFilter termSizeFilter
        rowsFilterT = rowsFilter <<< snd
        addOccWithFilter ne ngramsElement =
          if rowsFilter ngramsElement then
            Just $ addOcc ne ngramsElement
          else
            Nothing
        addOcc ne ngramsElement =
          let Additive occurrences = sumOccurrences ngramsTable ngramsElement in
          ngramsElement # _NgramsElement <<< _occurrences .~ occurrences
        addOccT (Tuple ne ngramsElement) = Tuple ne $ addOcc ne ngramsElement

        allNgramsSelected = allNgramsSelectedOnFirstPage ngramsSelection filteredRows

        ngramsTable = applyNgramsPatches state initTable
        roots = rootsOf ngramsTable
        ngramsParentRoot :: Maybe NgramsTerm
        ngramsParentRoot =
          (\np -> ngramsTable ^? at np
                            <<< _Just
                            <<< _NgramsElement
                            <<< _root
                            <<< _Just
            ) =<< ngramsParent

        convertRow (Tuple ngrams ngramsElement) =
          { row: NTC.renderNgramsItem { dispatch: performAction
                                      , ngrams
                                      , ngramsElement
                                      , ngramsLocalPatch
                                      , ngramsParent
                                      , ngramsSelection
                                      , ngramsTable }
          , delete: false
          }
        orderWith =
          case convOrderBy <$> params.orderBy of
            Just ScoreAsc  -> L.sortWith \x -> (snd x)        ^. _NgramsElement <<< _occurrences
            Just ScoreDesc -> L.sortWith \x -> Down $ (snd x) ^. _NgramsElement <<< _occurrences
            Just TermAsc   -> L.sortWith \x -> (snd x)        ^. _NgramsElement <<< _ngrams
            Just TermDesc  -> L.sortWith \x -> Down $ (snd x) ^. _NgramsElement <<< _ngrams
            _              -> identity -- the server ordering is enough here

        colNames = T.ColumnName <$> ["Select", "Map", "Stop", "Terms", "Score"] -- see convOrderBy
        -- This is used to *decorate* the Select header with the checkbox.
        wrapColElts scProps (T.ColumnName "Select") = const [NTC.selectionCheckbox scProps]
        wrapColElts _       (T.ColumnName "Score")  = (_ <> [H.text ("(" <> show scoreType <> ")")])
        wrapColElts _       _                       = identity
        setParams f = setPath $ \p@{params: ps} -> p {params = f ps}

        search :: R.Element
        search = NTC.searchInput { key: "search-input"
                                 , onSearch: setSearchQuery
                                 , searchQuery: searchQuery }
        setSearchQuery :: String -> Effect Unit
        setSearchQuery x    = setPath $ _ { searchQuery    = x }


displayRow :: State -> SearchQuery -> NgramsTable -> Maybe NgramsTerm -> Maybe TermList -> Maybe TermSize -> NgramsElement -> Boolean
displayRow state@{ ngramsChildren
                 , ngramsLocalPatch
                 , ngramsParent }
           searchQuery
           ngramsTable
           ngramsParentRoot
           termListFilter
           termSizeFilter
           (NgramsElement {ngrams, root, list}) =
  (
      isNothing root
    -- ^ Display only nodes without parents
    && maybe true (_ == list) termListFilter
    -- ^ and which matches the ListType filter.
    && 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
    && filterTermSize termSizeFilter ngrams
    -- ^ and which satisfies the chosen term size
    || ngramsChildren ^. at ngrams == Just false
    -- ^ unless they are scheduled to be removed.
    || NTC.tablePatchHasNgrams ngramsLocalPatch ngrams
    -- ^ unless they are being processed at the moment.
  )
    && queryMatchesLabel searchQuery (ngramsTermText ngrams)
    -- ^ and which matches the search query.


allNgramsSelectedOnFirstPage :: Set NgramsTerm -> PreConversionRows -> Boolean
allNgramsSelectedOnFirstPage selected rows = selected == (selectNgramsOnFirstPage rows)

selectNgramsOnFirstPage :: PreConversionRows -> Set NgramsTerm
selectNgramsOnFirstPage rows = Set.fromFoldable $ fst <$> rows


type MainNgramsTableProps =
  ( nodeId        :: Int
    -- ^ This node can be a corpus or contact.
  , defaultListId :: Int
  , tabType       :: TabType
  , session       :: Session
  , tabNgramType  :: CTabNgramType
  , withAutoUpdate :: Boolean
  )

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

mainNgramsTableCpt :: R.Component MainNgramsTableProps
mainNgramsTableCpt = R.hooksComponent "G.C.NT.mainNgramsTable" cpt
  where
    cpt props@{nodeId, defaultListId, tabType, session, tabNgramType, withAutoUpdate} _ = do
      let path = initialPageParams session nodeId [defaultListId] tabType

      useLoaderWithCacheAPI {
          cacheEndpoint: versionEndpoint props
        , handleResponse
        , mkRequest
        , path
        , renderer: \versioned -> mainNgramsTablePaint { path, tabNgramType, versioned, withAutoUpdate }
        }

    versionEndpoint :: Record MainNgramsTableProps -> PageParams -> Aff Version
    versionEndpoint { defaultListId, nodeId, session, tabType } _ = get session $ R.GetNgramsTableVersion { listId: defaultListId, tabType } (Just nodeId)

    mkRequest :: PageParams -> GUC.Request
    mkRequest path@{ session } = GUC.makeGetRequest session $ url path
      where
        url { listIds
            , nodeId
            , params: { limit, offset, orderBy }
            , searchQuery
            , scoreType
            , tabType
            , termListFilter
            , termSizeFilter
            } = R.GetNgrams { limit
                            , listIds
                            , offset: Just offset
                            , orderBy: convOrderBy <$> orderBy
                            , searchQuery
                            , tabType
                            , termListFilter
                            , termSizeFilter } (Just nodeId)

    handleResponse :: VersionedNgramsTable -> VersionedNgramsTable
    handleResponse v = v

    pathNoLimit :: PageParams -> PageParams
    pathNoLimit path@{ params } = path { params = params { limit = 100000 }
                                       , termListFilter = Nothing }

type MainNgramsTablePaintProps =
  (
    path :: PageParams
  , tabNgramType  :: CTabNgramType
  , versioned :: VersionedNgramsTable
  , withAutoUpdate :: Boolean
  )

mainNgramsTablePaint :: Record MainNgramsTablePaintProps -> R.Element
mainNgramsTablePaint p = R.createElement mainNgramsTablePaintCpt p []

mainNgramsTablePaintCpt :: R.Component MainNgramsTablePaintProps
mainNgramsTablePaintCpt = R.hooksComponent "G.C.NT.mainNgramsTablePaint" cpt
  where
    cpt {path, tabNgramType, versioned, withAutoUpdate} _ = do
      pathS <- R.useState' path
      state <- R.useState' $ initialState versioned
      pure $ loadedNgramsTable {
        path: pathS
      , state
      , tabNgramType
      , versioned
      , withAutoUpdate
      }

sumOccurrences :: NgramsTable -> NgramsElement -> Additive Int
sumOccurrences ngramsTable (NgramsElement {occurrences, children}) =
    Additive occurrences <> children ^. folded <<< to (sumOccurrences' ngramsTable)
    where
      sumOccurrences' :: NgramsTable -> NgramsTerm -> Additive Int
      sumOccurrences' nt label =
          nt ^. ix label <<< to (sumOccurrences nt)

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