module Gargantext.Components.NgramsTable ( PageParams , PatchMap , NgramsPatch , NgramsTable , VersionedNgramsTable , Version , Versioned(..) , Action , initialPageParams , initialState , ngramsTableSpec , ngramsLoaderClass , ngramsLoader , ngramsTableClass , MainNgramsTableProps , mainNgramsTableSpec ) where import Control.Monad.State (class MonadState, execState) import Control.Monad.Cont.Trans (lift) import Data.Array (head) import Data.Argonaut ( class DecodeJson, decodeJson, class EncodeJson, encodeJson , jsonEmptyObject, (:=), (~>), (.?), (.??) ) import Data.Either (Either(..)) import Data.Foldable (class Foldable, foldMap, foldl, foldr) import Data.FoldableWithIndex (class FoldableWithIndex, foldMapWithIndex, foldlWithIndex, foldrWithIndex) import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex) import Data.Newtype (class Newtype) import Data.Lens (Iso', Lens', (%~), (.=), (^.), (^..)) import Data.Lens.Common (_Just) import Data.Lens.At (class At, at) import Data.Lens.Index (class Index, ix) import Data.Lens.Fold (folded) import Data.Lens.Record (prop) import Data.Lens.Iso.Newtype (_Newtype) import Data.List as List import Data.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(..), maybe) import Data.Traversable (class Traversable, traverse, traverse_, sequence) import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex) import Data.Set (Set) import Data.Set as Set import Data.Symbol (SProxy(..)) import Data.Tuple (Tuple(..)) import Effect (Effect) import Effect.Aff (Aff) import Foreign.Object as FO import React (ReactElement) import React as React 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, defaultValue, value) import React.DOM.Props as DOM import Thermite (PerformAction, Render, Spec, StateCoTransformer, defaultPerformAction, modifyState_, simpleSpec, createClass) import Unsafe.Coerce (unsafeCoerce) import Gargantext.Types (TermList(..), TermSize, readTermList, readTermSize, termLists, termSizes) import Gargantext.Config (toUrl, End(..), Path(..), TabType(..), OrderBy(..)) import Gargantext.Config.REST (get, put) import Gargantext.Components.AutoUpdate (autoUpdateElt) import Gargantext.Components.Table as T import Gargantext.Prelude import Gargantext.Components.Loader as Loader type PageParams = { nodeId :: Int , listIds :: Array Int , params :: T.Params , tabType :: TabType , searchQuery :: String , termListFilter :: Maybe TermList -- Nothing means all , termSizeFilter :: Maybe TermSize -- Nothing means all } initialPageParams :: Int -> Array Int -> TabType -> PageParams initialPageParams nodeId listIds tabType = { nodeId , listIds , params: T.initialParams , tabType , termSizeFilter: Nothing , termListFilter: Just GraphTerm , searchQuery: "" } type Props' = Loader.InnerProps PageParams VersionedNgramsTable () type NgramsTerm = String newtype NgramsElement = NgramsElement { ngrams :: NgramsTerm , list :: TermList , occurrences :: Int , parent :: Maybe NgramsTerm , children :: Set NgramsTerm } _parent = prop (SProxy :: SProxy "parent") _children :: forall row. Lens' { children :: Set NgramsTerm | row } (Set NgramsTerm) _children = prop (SProxy :: SProxy "children") derive instance newtypeNgramsElement :: Newtype NgramsElement _ _NgramsElement :: Iso' NgramsElement _ _NgramsElement = _Newtype instance decodeJsonNgramsElement :: DecodeJson NgramsElement where decodeJson json = do obj <- decodeJson json ngrams <- obj .? "ngrams" list <- obj .? "list" occurrences <- obj .? "occurrences" parent <- obj .?? "parent" children' <- obj .? "children" let children = Set.fromFoldable (children' :: Array NgramsTerm) pure $ NgramsElement {ngrams, list, occurrences, parent, children} type Version = Int newtype Versioned a = Versioned { version :: Version , data :: a } instance encodeJsonVersioned :: EncodeJson a => EncodeJson (Versioned a) where encodeJson (Versioned {version, data: data_}) = "version" := version ~> "data" := data_ ~> jsonEmptyObject instance decodeJsonVersioned :: DecodeJson a => DecodeJson (Versioned a) where decodeJson json = do obj <- decodeJson json version <- obj .? "version" data_ <- obj .? "data" pure $ Versioned {version, data: data_} -- type NgramsTable = Array (NTree NgramsElement) -- type NgramsTable = Array NgramsElement newtype NgramsTable = NgramsTable (Map NgramsTerm NgramsElement) derive instance newtypeNgramsTable :: Newtype NgramsTable _ _NgramsTable :: Iso' NgramsTable (Map NgramsTerm NgramsElement) _NgramsTable = _Newtype instance indexNgramsTable :: Index NgramsTable String NgramsElement where ix k = _NgramsTable <<< ix k instance atNgramsTable :: At NgramsTable String NgramsElement where at k = _NgramsTable <<< at k instance decodeJsonNgramsTable :: DecodeJson NgramsTable where decodeJson json = do elements <- decodeJson json pure $ NgramsTable $ Map.fromFoldable $ f <$> (elements :: Array NgramsElement) where f e@(NgramsElement e') = Tuple e'.ngrams e type VersionedNgramsTable = Versioned NgramsTable data Replace a = Keep | Replace { old :: a, new :: a } replace :: forall a. Eq a => a -> a -> Replace a replace old new | old == new = Keep | otherwise = Replace { old, new } instance semigroupReplace :: Semigroup (Replace a) where append Keep p = p append p Keep = p append (Replace { old: _m, new }) (Replace { old, new: _m' }) = -- assert _m == _m' Replace { old, new } instance semigroupMonoid :: Monoid (Replace a) where mempty = Keep applyReplace :: forall a. Eq a => Replace a -> a -> a applyReplace Keep a = a applyReplace (Replace { old, new }) a | a == old = new | otherwise = a instance encodeJsonReplace :: EncodeJson a => EncodeJson (Replace a) where encodeJson Keep = "tag" := "Keep" ~> jsonEmptyObject encodeJson (Replace {old, new}) = "old" := old ~> "new" := new ~> "tag" := "Replace" ~> jsonEmptyObject instance decodeJsonReplace :: (DecodeJson a, Eq a) => DecodeJson (Replace a) where decodeJson json = do obj <- decodeJson json mold <- obj .?? "old" mnew <- obj .?? "new" case Tuple mold mnew of Tuple (Just old) (Just new) -> pure $ replace old new Tuple Nothing Nothing -> pure Keep _ -> Left "decodeJsonReplace" -- Representing a PatchSet as `Map a Boolean` would have the advantage -- of enforcing rem and add to be disjoint. newtype PatchSet a = PatchSet { rem :: Set a , add :: Set a } instance semigroupPatchSet :: Ord a => Semigroup (PatchSet a) where append (PatchSet p) (PatchSet q) = PatchSet { rem: q.rem <> p.rem , add: Set.difference q.add p.rem <> p.add } instance monoidPatchSet :: Ord a => Monoid (PatchSet a) where mempty = PatchSet { rem: Set.empty, add: Set.empty } instance encodeJsonPatchSet :: EncodeJson a => EncodeJson (PatchSet a) where encodeJson (PatchSet {rem, add}) -- TODO only include non empty fields = "rem" := (Set.toUnfoldable rem :: Array a) ~> "add" := (Set.toUnfoldable add :: Array a) ~> jsonEmptyObject instance decodeJsonPatchSet :: (Ord a, DecodeJson a) => DecodeJson (PatchSet a) where decodeJson json = do -- TODO handle empty fields obj <- decodeJson json rem <- mkSet <$> (obj .? "rem") add <- mkSet <$> (obj .? "add") pure $ PatchSet { rem, add } where mkSet :: forall b. Ord b => Array b -> Set b mkSet = Set.fromFoldable applyPatchSet :: forall a. Ord a => PatchSet a -> Set a -> Set a applyPatchSet (PatchSet p) s = Set.difference s p.rem <> p.add patchSetFromMap :: forall a. Ord a => Map a Boolean -> PatchSet a patchSetFromMap m = PatchSet { rem: Map.keys (Map.filter not m) , add: Map.keys (Map.filter identity m) } -- TODO Map.partition would be nice here newtype NgramsPatch = NgramsPatch { patch_children :: PatchSet NgramsTerm , patch_list :: Replace TermList } instance semigroupNgramsPatch :: Semigroup NgramsPatch where append (NgramsPatch p) (NgramsPatch q) = NgramsPatch { patch_children: p.patch_children <> q.patch_children , patch_list: p.patch_list <> q.patch_list } instance monoidNgramsPatch :: Monoid NgramsPatch where mempty = NgramsPatch { patch_children: mempty, patch_list: mempty } instance encodeJsonNgramsPatch :: EncodeJson NgramsPatch where -- TODO only include non empty fields encodeJson (NgramsPatch { patch_children, patch_list }) = "patch_children" := patch_children ~> "patch_list" := patch_list ~> jsonEmptyObject instance decodeJsonNgramsPatch :: DecodeJson NgramsPatch where decodeJson json = do obj <- decodeJson json -- TODO handle empty fields patch_list <- obj .? "patch_list" patch_children <- obj .? "patch_children" pure $ NgramsPatch { patch_list, patch_children } applyNgramsPatch :: NgramsPatch -> NgramsElement -> NgramsElement applyNgramsPatch (NgramsPatch p) (NgramsElement e) = NgramsElement { ngrams: e.ngrams , list: applyReplace p.patch_list e.list , occurrences: e.occurrences -- TODO: is this correct ? , parent: e.parent , children: applyPatchSet p.patch_children e.children } newtype PatchMap k p = PatchMap (Map k p) instance semigroupPatchMap :: (Ord k, Semigroup p) => Semigroup (PatchMap k p) where append (PatchMap p) (PatchMap q) = PatchMap (Map.unionWith append p q) instance monoidPatchMap :: (Ord k, Semigroup p) => Monoid (PatchMap k p) where mempty = PatchMap Map.empty derive instance newtypePatchMap :: Newtype (PatchMap k p) _ _PatchMap :: forall k p. Iso' (PatchMap k p) (Map k p) _PatchMap = _Newtype instance functorPatchMap :: Functor (PatchMap k) where map f (PatchMap m) = PatchMap (map f m) instance functorWithIndexPatchMap :: FunctorWithIndex k (PatchMap k) where mapWithIndex f (PatchMap m) = PatchMap (mapWithIndex f m) instance foldlablePatchMap :: Foldable (PatchMap k) where foldr f z (PatchMap m) = foldr f z m foldl f z (PatchMap m) = foldl f z m foldMap f (PatchMap m) = foldMap f m instance foldlableWithIndexPatchMap :: FoldableWithIndex k (PatchMap k) where foldrWithIndex f z (PatchMap m) = foldrWithIndex f z m foldlWithIndex f z (PatchMap m) = foldlWithIndex f z m foldMapWithIndex f (PatchMap m) = foldMapWithIndex f m instance traversablePatchMap :: Traversable (PatchMap k) where traverse f (PatchMap m) = PatchMap <$> traverse f m sequence (PatchMap m) = PatchMap <$> sequence m instance traversableWithIndexPatchMap :: TraversableWithIndex k (PatchMap k) where traverseWithIndex f (PatchMap m) = PatchMap <$> traverseWithIndex f m instance encodeJsonPatchMap :: EncodeJson p => EncodeJson (PatchMap String p) where encodeJson (PatchMap m) = encodeJson $ FO.fromFoldable $ (Map.toUnfoldable m :: Array _) instance decodeJsonPatchMap :: DecodeJson p => DecodeJson (PatchMap String p) where decodeJson json = do obj <- decodeJson json pure $ PatchMap $ Map.fromFoldableWithIndex (obj :: FO.Object p) isEmptyPatchMap :: forall k p. PatchMap k p -> Boolean isEmptyPatchMap (PatchMap p) = Map.isEmpty p applyPatchMap :: forall k p v. Ord k => (p -> v -> v) -> PatchMap k p -> Map k v -> Map k v applyPatchMap applyPatchValue (PatchMap p) = mapWithIndex f where f k v = case Map.lookup k p of Nothing -> v Just pv -> applyPatchValue pv v type NgramsTablePatch = PatchMap NgramsTerm NgramsPatch type ReParent a = forall m. MonadState NgramsTable m => a -> m Unit reParent :: Maybe NgramsTerm -> ReParent NgramsTerm reParent parent child = at child <<< _Just <<< _NgramsElement <<< _parent .= parent -- reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch -- ^ GHC would have accepted this type. Here reParentNgramsPatch checks but -- not its usage in reParentNgramsTablePatch. reParentNgramsPatch :: forall m. MonadState NgramsTable m => NgramsTerm -> NgramsPatch -> m Unit reParentNgramsPatch parent (NgramsPatch {patch_children: PatchSet {rem, add}}) = do traverse_ (reParent Nothing) rem traverse_ (reParent $ Just parent) add reParentNgramsTablePatch :: ReParent NgramsTablePatch reParentNgramsTablePatch = void <<< traverseWithIndex reParentNgramsPatch applyNgramsTablePatch :: NgramsTablePatch -> NgramsTable -> NgramsTable applyNgramsTablePatch p (NgramsTable m) = execState (reParentNgramsTablePatch p) $ NgramsTable $ applyPatchMap applyNgramsPatch p m -- TODO: update the .root fields... -- See ROOT-UPDATE type State = { ngramsTablePatch :: NgramsTablePatch , ngramsVersion :: Version , 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 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-4", style {marginTop : "37px"}] [ input [ className "form-control " , name "search", placeholder "Search" , _type "value" , value pageParams.searchQuery , onInput \e -> setSearchQuery (unsafeEventValue e) ] ] , div [_id "filter_terms", className "col-md-6", style{ marginTop : "2.1em",paddingLeft :"1em"}] [ div [className "col-md-10 list-group", style {marginTop : "6px"}] [ li [className " list-group-item"] [ select [ _id "picklistmenu" , className "form-control custom-select" , defaultValue (show pageParams.termListFilter) , onChange (\e -> setTermListFilter $ readTermList $ unsafeEventValue e) ] $ map optps1 termLists ] , li [className "list-group-item"] [ select [ _id "picktermtype" , className "form-control custom-select" , defaultValue (show pageParams.termSizeFilter) , onChange (\e -> setTermSizeFilter $ readTermSize $ unsafeEventValue e) ] $ map optps1 termSizes ] , li [className " list-group-item"] [ props.pageSizeControl ] ] ] , div [className "col-md-6", style {marginTop : "24px", marginBottom : "14px"}] [ props.pageSizeDescription , props.paginationLinks ] ] ] , div [] (maybe [] (\ngrams -> let ngramsTable = ngramsTableCache # at ngrams <<< _Just <<< _NgramsElement <<< _children %~ applyPatchSet (patchSetFromMap ngramsChildren) ngramsClick child | child == ngrams = Nothing | otherwise = Just $ dispatch $ ToggleChild false child in [ p[] [text $ "Editing " <> ngrams] , renderNgramsTree { ngramsTable, ngrams, ngramsStyle: [], ngramsClick } , 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 } putTable :: {nodeId :: Int, listIds :: Array Int, tabType :: TabType} -> Versioned NgramsTablePatch -> Aff (Versioned NgramsTablePatch) putTable {nodeId, listIds, tabType} = put (toUrl Back (PutNgrams tabType (head listIds)) $ Just nodeId) commitPatch :: {nodeId :: Int, listIds :: Array Int, tabType :: TabType} -> Versioned NgramsTablePatch -> StateCoTransformer State Unit commitPatch props pt@(Versioned {data: tablePatch}) = do Versioned {version: newVersion, data: newPatch} <- lift $ putTable props pt modifyState_ $ \s -> s { ngramsVersion = newVersion , ngramsTablePatch = newPatch <> tablePatch <> s.ngramsTablePatch } -- TODO: check that pt.version == s.ngramsTablePatch.version toggleMap :: forall a. a -> Maybe a -> Maybe a toggleMap _ (Just _) = Nothing toggleMap b Nothing = Just b ngramsTableSpec :: Spec State Props' Action ngramsTableSpec = simpleSpec performAction render where setParentResetChildren :: Maybe NgramsTerm -> State -> State setParentResetChildren p = _ { ngramsParent = p, ngramsChildren = mempty } performAction :: PerformAction State Props' 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 listId = Just 10 -- List.head listIds pe = NgramsPatch { patch_list: pl, patch_children: mempty } pt = PatchMap $ Map.singleton 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 listId = Just 10 -- List.head listIds 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. render :: Render State Props' 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 <$> [ "Graph" , "Stop" , "Terms" , "Occurences (nb)" ] , totalRecords: 47361 -- TODO } ] where setParams params = loaderDispatch $ Loader.SetPath $ pageParams {params = params} ngramsTable = applyNgramsTablePatch ngramsTablePatch initTable rows = convertRow <$> Map.toUnfoldable (Map.filter displayRow (ngramsTable ^. _NgramsTable)) isRoot (NgramsElement e) = e.parent == Nothing -- TODO: There is a missing case where we display a row that we should not. -- Assumptions: -- * cats -> cat -> animal -- * We are editing cats: ngramsParent == Just "cats" -- * animal should not be listed since this would create a cycle! displayRow e@(NgramsElement {ngrams, children}) = isRoot e -- ^ Display only nodes with parents && (ngramsChildren ^. at ngrams /= Just true) -- ^ and which are not scheduled to be added already. && (case ngramsParent of Just p -> ngrams /= p && -- ^ and which is not the node being currently edited. not (Set.member p children) -- ^ ... or one of its children. Nothing -> true) || -- Unless they are scheduled to be removed. (ngramsChildren ^. at ngrams == Just false) convertRow (Tuple ngrams (NgramsElement { occurrences, list })) = { row: renderNgramsItem { ngramsTable, ngrams, occurrences, ngramsParent, termList: list, dispatch } , delete: false } loadPage :: PageParams -> Aff VersionedNgramsTable loadPage { nodeId, listIds, termListFilter, termSizeFilter , searchQuery, tabType, params: {offset, limit, orderBy}} = get $ toUrl Back (GetNgrams { tabType, offset, limit, listIds , orderBy: convOrderBy <$> orderBy , termListFilter, termSizeFilter , searchQuery }) (Just nodeId) where convOrderBy _ = DateAsc -- TODO ngramsLoaderClass :: Loader.LoaderClass PageParams VersionedNgramsTable ngramsLoaderClass = Loader.createLoaderClass "NgramsTableLoader" loadPage ngramsLoader :: Loader.Props' PageParams VersionedNgramsTable -> ReactElement ngramsLoader props = React.createElement ngramsLoaderClass props [] 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 } ] tree :: { ngramsTable :: NgramsTable , ngramsStyle :: Array DOM.Props , ngramsClick :: NgramsTerm -> Maybe (Effect Unit) } -> NgramsTerm -> ReactElement tree params@{ngramsTable, ngramsStyle, ngramsClick} label = li [ style {width : "100%"} ] [ i icon [] , tag [text $ " " <> label] , forest cs ] where tag = case ngramsClick label of Just effect -> a (ngramsStyle <> [onClick $ const effect]) Nothing -> span ngramsStyle leaf = List.null cs icon = gray <> [className $ "fas fa-caret-" <> if open then "down" else "right"] open = not leaf || false {- TODO -} gray = if leaf then [style {color: "#adb5bd"}] else [] cs = ngramsTable ^.. ix label <<< _NgramsElement <<< _children <<< folded forest = ul [] <<< map (tree params) <<< List.toUnfoldable renderNgramsTree :: { ngrams :: NgramsTerm , ngramsTable :: NgramsTable , ngramsStyle :: Array DOM.Props , ngramsClick :: NgramsTerm -> Maybe (Effect Unit) } -> ReactElement renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick } = ul [] [ span [className "tree"] [tree {ngramsTable, ngramsStyle, ngramsClick} ngrams] ] renderNgramsItem :: { ngrams :: NgramsTerm , ngramsTable :: NgramsTable , occurrences :: Int , termList :: TermList , ngramsParent :: Maybe NgramsTerm , dispatch :: Action -> Effect Unit } -> Array ReactElement renderNgramsItem { ngramsTable, ngrams, occurrences, termList, ngramsParent, dispatch } = [ checkbox GraphTerm , checkbox StopTerm , if ngramsParent == Nothing then renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick } else a [onClick $ const $ dispatch $ ToggleChild true ngrams] [ i [className "fas fa-plus"] [] , span ngramsStyle [text $ " " <> ngrams] ] , text $ show occurrences ] where ngramsStyle = [termStyle termList] ngramsClick = Just <<< dispatch <<< SetParentResetChildren <<< Just 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'') ] setTermList Keep = pure unit setTermList rep@(Replace {old,new}) = dispatch $ SetTermListItem ngrams rep termStyle :: TermList -> DOM.Props termStyle GraphTerm = style {color: "green"} termStyle StopTerm = style {color: "red", textDecoration : "line-through"} termStyle CandidateTerm = style {color: "black"} 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