[NGRAMS] display the tree of ngrams

parent cb9cfeca
...@@ -151,8 +151,10 @@ layoutDocview = simpleSpec performAction render ...@@ -151,8 +151,10 @@ layoutDocview = simpleSpec performAction render
-- * should we locally update our data? -- * should we locally update our data?
-- * should we reset documentIdsToDelete? -- * should we reset documentIdsToDelete?
-- * if so, how to un-check the checkboxes since the inputs are uncontrolled? -- * if so, how to un-check the checkboxes since the inputs are uncontrolled?
-- (maybe there is no need to uncheck them if they disapear because we -- + There is no need to uncheck them if they disapear because we
-- either reload or local update our data) -- either reload or local update our data.
-- + Sync the checked value using
-- `checked: Set.member n state.documentIdsToDelete`
render :: Render State Props Action render :: Render State Props Action
render dispatch {path: nodeId, loaded: corpusInfo} _ _ = render dispatch {path: nodeId, loaded: corpusInfo} _ _ =
......
...@@ -6,13 +6,19 @@ import Data.Array (filter, toUnfoldable) ...@@ -6,13 +6,19 @@ import Data.Array (filter, toUnfoldable)
import Data.Either (Either(..)) import Data.Either (Either(..))
import Data.FunctorWithIndex import Data.FunctorWithIndex
import Data.Newtype (class Newtype, unwrap) import Data.Newtype (class Newtype, unwrap)
import Data.Lens (Lens', Prism', lens, over, prism) import Data.Lens (Lens', Prism', lens, over, prism, (^..))
import Data.Lens.At (class At, at)
import Data.Lens.Index (class Index, ix)
import Data.Lens.Fold (folded)
import Data.Lens.Getter (to)
import Data.Lens.Iso (re) import Data.Lens.Iso (re)
import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List) import Data.List (List)
import Data.List as List
import Data.Map (Map) import Data.Map (Map)
import Data.Map as Map import Data.Map as Map
import Data.Maybe (Maybe(..), maybe) import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (traverse)
import Data.Set (Set) import Data.Set (Set)
import Data.Set as Set import Data.Set as Set
import Data.Tuple (Tuple(..), uncurry) import Data.Tuple (Tuple(..), uncurry)
...@@ -24,6 +30,7 @@ import React (ReactElement, ReactClass, Children) ...@@ -24,6 +30,7 @@ import React (ReactElement, ReactClass, Children)
import React as React import React as React
import React.DOM hiding (style, map) import React.DOM hiding (style, map)
import React.DOM.Props (_id, _type, checked, className, href, name, onChange, onClick, onInput, placeholder, scope, selected, style, value) import React.DOM.Props (_id, _type, checked, className, href, name, onChange, onClick, onInput, placeholder, scope, selected, style, value)
import React.DOM.Props as DOM
import Thermite (PerformAction, Spec, StateCoTransformer, Render, _render, modifyState_, defaultPerformAction, focusState, hideState, simpleSpec, createClass) import Thermite (PerformAction, Spec, StateCoTransformer, Render, _render, modifyState_, defaultPerformAction, focusState, hideState, simpleSpec, createClass)
import Unsafe.Coerce (unsafeCoerce) import Unsafe.Coerce (unsafeCoerce)
...@@ -55,6 +62,8 @@ newtype NgramsElement = NgramsElement ...@@ -55,6 +62,8 @@ newtype NgramsElement = NgramsElement
, children :: Set NgramsTerm , children :: Set NgramsTerm
} }
derive instance newtypeNgramsElement :: Newtype NgramsElement _
instance decodeJsonNgramsElement :: DecodeJson NgramsElement where instance decodeJsonNgramsElement :: DecodeJson NgramsElement where
decodeJson json = do decodeJson json = do
obj <- decodeJson json obj <- decodeJson json
...@@ -70,6 +79,14 @@ instance decodeJsonNgramsElement :: DecodeJson NgramsElement where ...@@ -70,6 +79,14 @@ instance decodeJsonNgramsElement :: DecodeJson NgramsElement where
-- type NgramsTable = Array NgramsElement -- type NgramsTable = Array NgramsElement
newtype NgramsTable = NgramsTable (Map NgramsTerm NgramsElement) newtype NgramsTable = NgramsTable (Map NgramsTerm NgramsElement)
derive instance newtypeNgramsTable :: Newtype NgramsTable _
instance indexNgramsTable :: Index NgramsTable String NgramsElement where
ix k = _Newtype <<< ix k
instance atNgramsTable :: At NgramsTable String NgramsElement where
at k = _Newtype <<< at k
instance decodeJsonNgramsTable :: DecodeJson NgramsTable where instance decodeJsonNgramsTable :: DecodeJson NgramsTable where
decodeJson json = do decodeJson json = do
elements <- decodeJson json elements <- decodeJson json
...@@ -307,10 +324,10 @@ ngramsTableSpec' = simpleSpec performAction render ...@@ -307,10 +324,10 @@ ngramsTableSpec' = simpleSpec performAction render
rows = rows =
case applyNgramsTablePatch ngramsTablePatch <$> initTable of case applyNgramsTablePatch ngramsTablePatch <$> initTable of
Nothing -> [] -- or an error Nothing -> [] -- or an error
Just (NgramsTable table) -> Just t@(NgramsTable table) ->
convertRow <$> Map.toUnfoldable (Map.filter isRoot table) convertRow t <$> Map.toUnfoldable (Map.filter isRoot table)
isRoot (NgramsElement e) = e.root == Nothing isRoot (NgramsElement e) = e.root == Nothing
convertRow (Tuple ngrams (NgramsElement { occurrences, list })) = convertRow table (Tuple ngrams (NgramsElement { occurrences, list })) =
{ row: { row:
let let
setTermList Keep = do setTermList Keep = do
...@@ -319,7 +336,7 @@ ngramsTableSpec' = simpleSpec performAction render ...@@ -319,7 +336,7 @@ ngramsTableSpec' = simpleSpec performAction render
setTermList rep@(Replace {old,new}) = do setTermList rep@(Replace {old,new}) = do
logs $ Tuple "setTermList" (Tuple old new) logs $ Tuple "setTermList" (Tuple old new)
dispatch $ SetTermListItem ngrams rep in dispatch $ SetTermListItem ngrams rep in
renderNgramsItem { ngrams, occurrences, termList: list, setTermList } renderNgramsItem { table, ngrams, occurrences, termList: list, setTermList }
, delete: false , delete: false
} }
...@@ -353,18 +370,32 @@ ngramsTableSpec = simpleSpec defaultPerformAction render ...@@ -353,18 +370,32 @@ ngramsTableSpec = simpleSpec defaultPerformAction render
, component: createClass "Layout" ngramsTableSpec' initialState , component: createClass "Layout" ngramsTableSpec' initialState
} ] } ]
renderNgramsItem :: { ngrams :: String tree :: NgramsTable -> DOM.Props -> NgramsTerm -> ReactElement
tree table props label =
li [ style {width : "100%"} ]
[ i [className "fas fa-folder-open"] [] -- TODO icon
, span [props] [text $ " " <> label]
, forest table props (table ^.. ix label <<< _Newtype <<< to _.children <<< folded)
]
forest :: NgramsTable -> DOM.Props -> List NgramsTerm -> ReactElement
forest table props = ul [] <<< map (tree table props) <<< List.toUnfoldable
renderNgramsItem :: { table :: NgramsTable
, ngrams :: String
, occurrences :: Int , occurrences :: Int
, termList :: TermList , termList :: TermList
, setTermList :: Replace TermList -> Effect Unit , setTermList :: Replace TermList -> Effect Unit
} -> Array ReactElement } -> Array ReactElement
renderNgramsItem { ngrams, occurrences, termList, setTermList } = renderNgramsItem { table, ngrams, occurrences, termList, setTermList } =
[ checkbox GraphTerm [ checkbox GraphTerm
, checkbox StopTerm , checkbox StopTerm
, span [termStyle termList] [text ngrams] , span [className "tree"]
[ forest table (termStyle termList) (List.singleton ngrams) ]
, text $ show occurrences , text $ show occurrences
] ]
where where
checkbox termList' = checkbox termList' =
let chkd = termList == termList' let chkd = termList == termList'
termList'' = if chkd then CandidateTerm else termList' termList'' = if chkd then CandidateTerm else termList'
...@@ -377,7 +408,7 @@ renderNgramsItem { ngrams, occurrences, termList, setTermList } = ...@@ -377,7 +408,7 @@ renderNgramsItem { ngrams, occurrences, termList, setTermList } =
, onChange $ const $ setTermList (replace termList termList'') , onChange $ const $ setTermList (replace termList termList'')
] ]
-- termStyle :: TermList -> {} termStyle :: TermList -> DOM.Props
termStyle GraphTerm = style {color: "green"} termStyle GraphTerm = style {color: "green"}
termStyle StopTerm = style {color: "red", textDecoration : "line-through"} termStyle StopTerm = style {color: "red", textDecoration : "line-through"}
termStyle CandidateTerm = style {color: "black"} termStyle CandidateTerm = style {color: "black"}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment