Skip to content

P
purescript-gargantext
Commit f844290a authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

Merge branch 'dev' into dev-doc-table-optimization

parents c86fd7e8 1a198895
Hide whitespace changes
Inline Side-by-side
Showing with 491 additions and 282 deletions
dist/styles/Login.css
View file @ f844290a
......@@ -204,6 +204,7 @@ a:focus, a:hover {
.copy-from-corpus .tree .node {
padding-left: 10px;
margin-top: 5px;
}
.copy-from-corpus .tree .node .name.clickable {
color: #337ab7;
......
dist/styles/Login.sass
View file @ f844290a
......@@ -192,6 +192,7 @@ a:focus, a:hover
.tree
.node
padding-left: 10px
margin-top: 5px
.name
&.clickable
color: #337ab7
......
package.json
View file @ f844290a
{
"name": "Gargantext",
"version": "0.0.1.6.2",
"version": "0.0.1.6.3",
"scripts": {
"rebase-set": "spago package-set-upgrade && spago psc-package-insdhall",
"rebuild-set": "spago psc-package-insdhall",
......
src/Gargantext/Components/Annotation/Menu.purs
View file @ f844290a
......@@ -38,7 +38,7 @@ annotationMenuCpt :: R.Component Props
annotationMenuCpt = R.hooksComponent "Annotation.Menu" cpt
where
cpt props _ = pure $ R.fragment $ children props
children props = A.mapMaybe (addToList props) [ GraphTerm, CandidateTerm, StopTerm ]
children props = A.mapMaybe (addToList props) [ MapTerm, CandidateTerm, StopTerm ]
-- | Given the TermList to render the item for zand the Maybe TermList the item may belong to, possibly render the menuItem
addToList :: Record Props -> TermList -> Maybe R.Element
......
src/Gargantext/Components/Annotation/Utils.purs
View file @ f844290a
......@@ -3,11 +3,11 @@ module Gargantext.Components.Annotation.Utils where
import Gargantext.Types ( TermList(..) )
termClass :: TermList -> String
termClass GraphTerm = "graph-term"
termClass MapTerm = "graph-term"
termClass StopTerm = "stop-term"
termClass CandidateTerm = "candidate-term"
termBootstrapClass :: TermList -> String
termBootstrapClass GraphTerm = "success"
termBootstrapClass MapTerm = "success"
termBootstrapClass StopTerm = "danger"
termBootstrapClass CandidateTerm = "warning"
src/Gargantext/Components/Charts/Options/Series.purs
View file @ f844290a
......@@ -185,24 +185,23 @@ toJsTree maybeSurname (TreeNode x) =
where
name = maybe "" (\x' -> x' <> ">") maybeSurname <> x.name
data TreeNode = TreeNode { name :: String
, value :: Int
, children :: Array TreeNode
}
data TreeNode = TreeNode {
name :: String
, value :: Int
, children :: Array TreeNode
}
instance decodeTreeNode :: DecodeJson TreeNode where
decodeJson json = do
obj <- decodeJson json
children <- obj .: "children"
name <- obj .: "label"
value <- obj .: "value"
children <- obj .: "children"
pure $ TreeNode {name, value, children}
pure $ TreeNode { children, name, value }
instance encodeTreeNode :: EncodeJson TreeNode where
encodeJson (TreeNode { children, name, value }) =
"children" := encodeJson children
~> "name" := encodeJson name
~> "label" := encodeJson name
~> "value" := encodeJson value
~> jsonEmptyObject
......
src/Gargantext/Components/FacetsTable.purs
View file @ f844290a
......@@ -348,7 +348,7 @@ pageCpt = R.hooksComponent "G.C.FacetsTable.Page" cpt
]
, delete: true }
where
markClick _ = markCategory session nodeId category [id]
markClick _ = markCategory session nodeId category [id]
toggleClick _ = togglePendingDeletion deletions id
maybeStricken delete
| delete = H.div { style: { textDecoration: "line-through" } }
......
src/Gargantext/Components/Forest/Tree.purs
View file @ f844290a
......@@ -10,6 +10,7 @@ import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Forest.Tree.Node (nodeMainSpan)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree.Types (SubTreeOut(..))
import Gargantext.Components.Forest.Tree.Node.Action (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Add (AddNodeValue(..), addNode)
import Gargantext.Components.Forest.Tree.Node.Action.Delete (deleteNode)
......@@ -104,8 +105,6 @@ getNodeTree :: Session -> GT.ID -> Aff FTree
getNodeTree session nodeId = get session $ GR.NodeAPI GT.Tree (Just nodeId) ""
--------------
type TreeViewProps = ( asyncTasks :: R.State GAT.Storage
, tree :: FTree
, tasks :: Record Tasks
......@@ -306,17 +305,26 @@ performAction (UploadFile nodeType fileType mName contents) { session
performAction DownloadNode _ = do
liftEffect $ log "[performAction] DownloadNode"
-------
performAction (MoveNode n1 n2) p@{session} = do
void $ moveNodeReq session n1 n2
performAction RefreshTree p
performAction (MoveNode {params}) p@{session} =
case params of
Nothing -> performAction NoAction p
Just (SubTreeOut {in:in',out}) -> do
void $ moveNodeReq session in' out
performAction RefreshTree p
performAction (MergeNode n1 n2) p@{session} = do
void $ mergeNodeReq session n1 n2
performAction RefreshTree p
performAction (MergeNode {params}) p@{session} =
case params of
Nothing -> performAction NoAction p
Just (SubTreeOut {in:in',out}) -> do
void $ mergeNodeReq session in' out
performAction RefreshTree p
performAction (LinkNode n1 n2) p@{session} = do
void $ linkNodeReq session n1 n2
performAction RefreshTree p
performAction (LinkNode {params}) p@{session} =
case params of
Nothing -> performAction NoAction p
Just (SubTreeOut {in:in',out}) -> do
void $ linkNodeReq session in' out
performAction RefreshTree p
-------
performAction RefreshTree { reload: (_ /\ setReload) } = do
......
src/Gargantext/Components/Forest/Tree/Node.purs
View file @ f844290a
......@@ -14,6 +14,7 @@ import Gargantext.Components.Forest.Tree.Node.Box.Types (CommonProps)
import Gargantext.Components.Forest.Tree.Node.Tools.ProgressBar (asyncProgressBar, BarType(..))
import Gargantext.Components.Forest.Tree.Node.Tools.Task (Tasks)
import Gargantext.Components.Forest.Tree.Node.Tools.Sync (nodeActionsGraph, nodeActionsNodeList)
import Gargantext.Components.Forest.Tree.Node.Tools (nodeText)
import Gargantext.Components.GraphExplorer.API as GraphAPI
import Gargantext.Components.Lang (Lang(EN))
import Gargantext.Components.Nodes.Corpus (loadCorpusWithChild)
......@@ -166,28 +167,6 @@ fldr nt open = if open
-}
-- START node text
type NodeTextProps =
( isSelected :: Boolean
, name :: Name
)
nodeText :: Record NodeTextProps -> R.Element
nodeText p = R.createElement nodeTextCpt p []
nodeTextCpt :: R.Component NodeTextProps
nodeTextCpt = R.hooksComponent "G.C.F.T.N.B.nodeText" cpt
where
cpt { isSelected: true, name } _ = do
pure $ H.u {} [
H.b {} [
H.text ("| " <> name <> " | ")
]
]
cpt {isSelected: false, name} _ = do
pure $ H.text (name <> " ")
-- END node text
-- START nodeActions
type NodeActionsProps =
......
src/Gargantext/Components/Forest/Tree/Node/Action.purs
View file @ f844290a
module Gargantext.Components.Forest.Tree.Node.Action where
import Data.Maybe (Maybe)
import Data.Maybe (Maybe(..))
import Effect.Aff (Aff)
import Gargantext.Prelude (class Show, Unit)
import Gargantext.Sessions (Session)
import Gargantext.Types as GT
import Gargantext.Components.Forest.Tree.Node.Settings (NodeAction(..), glyphiconNodeAction, SubTreeParams(..))
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree.Types (SubTreeOut, SubTreeParams(..))
import Gargantext.Components.Forest.Tree.Node.Settings (NodeAction(..), glyphiconNodeAction)
import Gargantext.Components.Forest.Tree.Node.Action.Upload.Types (FileType, UploadFileContents)
import Gargantext.Components.Forest.Tree.Node.Action.Update.Types (UpdateNodeParams)
{-
type UpdateNodeProps =
( id :: GT.ID
, dispatch :: Action -> Aff Unit
, name :: GT.Name
, nodeType :: NodeType
, params :: UpdateNodeParams
type Props =
( dispatch :: Action -> Aff Unit
, id :: Int
, nodeType :: GT.NodeType
, session :: Session
)
-}
data Action = AddNode String GT.NodeType
| DeleteNode
......@@ -28,11 +28,27 @@ data Action = AddNode String GT.NodeType
| UploadFile GT.NodeType FileType (Maybe String) UploadFileContents
| DownloadNode
| RefreshTree
| MoveNode GT.NodeID GT.NodeID
| MergeNode GT.NodeID GT.NodeID
| LinkNode GT.NodeID GT.NodeID
| MoveNode {params :: Maybe SubTreeOut}
| MergeNode {params :: Maybe SubTreeOut}
| LinkNode {params :: Maybe SubTreeOut}
| NoAction
subTreeOut :: Action -> Maybe SubTreeOut
subTreeOut (MoveNode {params}) = params
subTreeOut (MergeNode {params}) = params
subTreeOut (LinkNode {params}) = params
subTreeOut _ = Nothing
setTreeOut :: Action -> Maybe SubTreeOut -> Action
setTreeOut (MoveNode {params:_}) p = MoveNode {params: p}
setTreeOut (MergeNode {params:_}) p = MergeNode {params: p}
setTreeOut (LinkNode {params:_}) p = LinkNode {params: p}
setTreeOut a _ = a
instance showShow :: Show Action where
show (AddNode _ _ )= "AddNode"
show DeleteNode = "DeleteNode"
......@@ -43,17 +59,11 @@ instance showShow :: Show Action where
show (UploadFile _ _ _ _)= "UploadFile"
show RefreshTree = "RefreshTree"
show DownloadNode = "Download"
show (MoveNode _ _) = "MoveNode"
show (MergeNode _ _) = "MergeNode"
show (LinkNode _ _) = "LinkNode"
show (MoveNode _ ) = "MoveNode"
show (MergeNode _ ) = "MergeNode"
show (LinkNode _ ) = "LinkNode"
show NoAction = "NoAction"
type Props =
( dispatch :: Action -> Aff Unit
, id :: Int
, nodeType :: GT.NodeType
, session :: Session
)
-----------------------------------------------------------------------
icon :: Action -> String
icon (AddNode _ _) = glyphiconNodeAction (Add [])
......@@ -65,9 +75,9 @@ icon (DoSearch _) = glyphiconNodeAction SearchBox
icon (UploadFile _ _ _ _) = glyphiconNodeAction Upload
icon RefreshTree = glyphiconNodeAction Refresh
icon DownloadNode = glyphiconNodeAction Download
icon (MoveNode _ _) = glyphiconNodeAction (Move { subTreeParams : SubTreeParams {showtypes:[], valitypes:[] }})
icon (MergeNode _ _) = glyphiconNodeAction (Merge { subTreeParams : SubTreeParams {showtypes:[], valitypes:[] }})
icon (LinkNode _ _) = glyphiconNodeAction (Link { subTreeParams : SubTreeParams {showtypes:[], valitypes:[] }})
icon (MoveNode _ ) = glyphiconNodeAction (Move { subTreeParams : SubTreeParams {showtypes:[], valitypes:[] }})
icon (MergeNode _ ) = glyphiconNodeAction (Merge { subTreeParams : SubTreeParams {showtypes:[], valitypes:[] }})
icon (LinkNode _ ) = glyphiconNodeAction (Link { subTreeParams : SubTreeParams {showtypes:[], valitypes:[] }})
icon NoAction = "hand-o-right"
......@@ -83,8 +93,8 @@ text (DoSearch _ )= "Launch search !"
text (UploadFile _ _ _ _)= "Upload File !"
text RefreshTree = "Refresh Tree !"
text DownloadNode = "Download !"
text (MoveNode _ _ ) = "Move !"
text (MergeNode _ _ ) = "Merge !"
text (LinkNode _ _ ) = "Link !"
text (MoveNode _ ) = "Move !"
text (MergeNode _ ) = "Merge !"
text (LinkNode _ ) = "Link !"
text NoAction = "No Action"
-----------------------------------------------------------------------
src/Gargantext/Components/Forest/Tree/Node/Action/Link.purs
View file @ f844290a
......@@ -6,7 +6,7 @@ import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff)
import Gargantext.Components.Forest.Tree.Node.Action (Action(..))
import Gargantext.Components.Forest.Tree.Node.Tools (submitButton, panel)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (SubTreeParamsIn, subTreeView, SubTreeOut(..))
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (subTreeView, SubTreeParamsIn)
import Gargantext.Prelude
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, put_)
......@@ -20,19 +20,21 @@ linkNodeReq session fromId toId =
linkNode :: Record SubTreeParamsIn -> R.Hooks R.Element
linkNode p@{dispatch, subTreeParams, id, nodeType, session} = do
subTreeOut@(subTreeOutParams /\ setSubTreeOut) :: R.State (Maybe SubTreeOut)
<- R.useState' Nothing
let button = case subTreeOutParams of
Nothing -> H.div {} []
Just sbto -> submitButton (LinkNode inId outId) dispatch
where
(SubTreeOut { in:inId, out:outId}) = sbto
pure $ panel [ subTreeView { subTreeOut
action@(valAction /\ setAction) :: R.State Action <- R.useState' (LinkNode {params:Nothing})
let button = case valAction of
LinkNode {params} -> case params of
Just val -> submitButton (LinkNode {params: Just val}) dispatch
Nothing -> H.div {} []
_ -> H.div {} []
pure $ panel [ subTreeView { action
, dispatch
, subTreeParams
, id
, nodeType
, session
, subTreeParams
}
] button
src/Gargantext/Components/Forest/Tree/Node/Action/Merge.purs
View file @ f844290a
......@@ -5,15 +5,15 @@ import Data.Maybe (Maybe(..))
import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff)
import Gargantext.Components.Forest.Tree.Node.Action (Action(..))
import Gargantext.Components.Forest.Tree.Node.Tools (submitButton, panel)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (SubTreeParamsIn, subTreeView, SubTreeOut(..))
import Gargantext.Components.Forest.Tree.Node.Tools (submitButton, panel, checkbox, checkboxes, divider)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (subTreeView, SubTreeParamsIn)
import Gargantext.Prelude
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, put_)
import Gargantext.Types as GT
import Reactix as R
import Reactix.DOM.HTML as H
import Data.Set as Set
mergeNodeReq :: Session -> GT.ID -> GT.ID -> Aff (Array GT.ID)
mergeNodeReq session fromId toId =
......@@ -21,19 +21,32 @@ mergeNodeReq session fromId toId =
mergeNode :: Record SubTreeParamsIn -> R.Hooks R.Element
mergeNode p@{dispatch, subTreeParams, id, nodeType, session} = do
subTreeOut@(subTreeOutParams /\ setSubTreeOut) :: R.State (Maybe SubTreeOut)
<- R.useState' Nothing
let button = case subTreeOutParams of
Nothing -> H.div {} []
Just sbto -> submitButton (MergeNode inId outId) dispatch
where
(SubTreeOut { in:inId, out:outId}) = sbto
pure $ panel [ subTreeView { subTreeOut
action@(valAction /\ setAction) :: R.State Action <- R.useState' (MergeNode {params:Nothing})
merge <- R.useState' false
options <- R.useState' (Set.singleton GT.MapTerm)
let button = case valAction of
MergeNode {params} -> case params of
Just val -> submitButton (MergeNode {params: Just val}) dispatch
Nothing -> H.div {} []
_ -> H.div {} []
pure $ panel [ subTreeView { action
, dispatch
, subTreeParams
, id
, nodeType
, session
, subTreeParams
}
, H.div { className:"panel panel-primary"}
[ H.text "Merge which list?"
, checkboxes [GT.MapTerm, GT.CandidateTerm, GT.StopTerm] options
]
, H.div { className:"panel panel-primary"}
[ H.text "Title"
, H.div {className: "checkbox"}
[checkbox merge, H.text "Merge data?"]
]
] button
src/Gargantext/Components/Forest/Tree/Node/Action/Move.purs
View file @ f844290a
......@@ -4,9 +4,9 @@ module Gargantext.Components.Forest.Tree.Node.Action.Move
import Data.Maybe (Maybe(..))
import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff)
import Gargantext.Components.Forest.Tree.Node.Action (Props, Action(..))
import Gargantext.Components.Forest.Tree.Node.Action (Action(..))
import Gargantext.Components.Forest.Tree.Node.Tools (submitButton, panel)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (SubTreeParamsIn, subTreeView, SubTreeOut(..))
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (subTreeView, SubTreeParamsIn)
import Gargantext.Prelude
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, put_)
......@@ -20,19 +20,20 @@ moveNodeReq session fromId toId =
moveNode :: Record SubTreeParamsIn -> R.Hooks R.Element
moveNode p@{dispatch, subTreeParams, id, nodeType, session} = do
subTreeOut@(subTreeOutParams /\ setSubTreeOut) :: R.State (Maybe SubTreeOut)
<- R.useState' Nothing
let button = case subTreeOutParams of
Nothing -> H.div {} []
Just sbto -> submitButton (MoveNode inId outId) dispatch
where
(SubTreeOut { in:inId, out:outId}) = sbto
pure $ panel [ subTreeView { subTreeOut
action@(valAction /\ setAction) :: R.State Action <- R.useState' (MoveNode {params: Nothing})
let button = case valAction of
MoveNode {params} -> case params of
Just val -> submitButton (MoveNode {params: Just val}) dispatch
Nothing -> H.div {} []
_ -> H.div {} []
pure $ panel [ subTreeView { action
, dispatch
, subTreeParams
, id
, nodeType
, session
, subTreeParams
}
] button
src/Gargantext/Components/Forest/Tree/Node/Box.purs
View file @ f844290a
......@@ -26,6 +26,7 @@ import Gargantext.Components.Forest.Tree.Node.Action.Link (linkNode)
import Gargantext.Components.Forest.Tree.Node.Action.Merge (mergeNode)
import Gargantext.Components.Forest.Tree.Node.Box.Types (NodePopupProps, NodePopupS)
import Gargantext.Components.Forest.Tree.Node.Settings (NodeAction(..), SettingsBox(..), glyphiconNodeAction, settingsBox)
import Gargantext.Components.Forest.Tree.Node.Status (Status(..), hasStatus)
import Gargantext.Components.Forest.Tree.Node.Tools (textInputBox, fragmentPT)
import Gargantext.Sessions (Session)
import Gargantext.Types (Name, ID)
......@@ -42,15 +43,6 @@ type CommonProps =
-- | START Popup View
iconAStyle :: { color :: String
, paddingTop :: String
, paddingBottom :: String
}
iconAStyle = { color : "black"
, paddingTop : "6px"
, paddingBottom : "6px"
}
nodePopupView :: Record NodePopupProps -> R.Element
nodePopupView p = R.createElement nodePopupCpt p []
......@@ -59,12 +51,17 @@ nodePopupCpt = R.hooksComponent "G.C.F.T.N.B.nodePopupView" cpt
where
cpt p _ = do
isOpen <- R.useState' false
nodePopupState@(nodePopup /\ setNodePopup) <- R.useState' { action : Nothing
, id : p.id
, name : p.name
, nodeType: p.nodeType
}
search <- R.useState' $ defaultSearch { node_id = Just p.id }
nodePopupState@(nodePopup /\ setNodePopup)
<- R.useState' { action : Nothing
, id : p.id
, name : p.name
, nodeType: p.nodeType
}
search <- R.useState'
$ defaultSearch { node_id = Just p.id }
pure $ H.div tooltipProps $
[ H.div { className: "popup-container" }
[ H.div { className: "panel panel-default" }
......@@ -145,11 +142,13 @@ nodePopupCpt = R.hooksComponent "G.C.F.T.N.B.nodePopupView" cpt
, H.div { className: "flex-center"}
[ buttonClick { action: doc
, state: nodePopupState
, nodeType
}
]
, H.div {className: "flex-center"}
$ map (\t -> buttonClick { action: t
, state : nodePopupState
, nodeType
}
) buttons
]
......@@ -184,6 +183,7 @@ type ActionState =
type ButtonClickProps =
( action :: NodeAction
, state :: R.State (Record ActionState)
, nodeType :: GT.NodeType
)
buttonClick :: Record ButtonClickProps -> R.Element
......@@ -192,16 +192,14 @@ buttonClick p = R.createElement buttonClickCpt p []
buttonClickCpt :: R.Component ButtonClickProps
buttonClickCpt = R.hooksComponent "G.C.F.T.N.B.buttonClick" cpt
where
cpt {action: todo, state: (node@{action} /\ setNodePopup)} _ = do
cpt {action: todo, state: (node@{action} /\ setNodePopup), nodeType} _ = do
pure $ H.div {className: "col-md-1"}
[ H.a { style: iconAStyle
[ H.a { style: (iconAStyle nodeType todo)
, className: glyphiconActive (glyphiconNodeAction todo)
(action == (Just todo) )
(action == (Just todo) )
, id: show todo
, title: show todo
, onClick : mkEffectFn1
$ \_ -> setNodePopup
$ const (node { action = action' })
, onClick : mkEffectFn1 $ \_ -> undo *> doToDo
}
[]
]
......@@ -210,6 +208,27 @@ buttonClickCpt = R.hooksComponent "G.C.F.T.N.B.buttonClick" cpt
then Nothing
else (Just todo)
undo = setNodePopup
$ const (node { action = Nothing })
doToDo = setNodePopup
$ const (node { action = action' })
iconAStyle :: GT.NodeType -> NodeAction -> { color :: String
, paddingTop :: String
, paddingBottom :: String
}
iconAStyle n a = { color : hasColor (hasStatus n a)
, paddingTop : "6px"
, paddingBottom : "6px"
}
where
hasColor :: Status -> String
hasColor Stable = "black"
hasColor Test = "orange"
hasColor Dev = "red"
-- END Popup View
type NodeProps =
( id :: ID
......
src/Gargantext/Components/Forest/Tree/Node/Settings.purs
View file @ f844290a
......@@ -4,6 +4,7 @@ import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Generic.Rep.Eq (genericEq)
import Gargantext.Prelude (class Eq, class Show, show, (&&), (<>), (==))
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree.Types (SubTreeParams(..))
import Data.Array (foldl)
import Gargantext.Types
......@@ -14,10 +15,6 @@ import Gargantext.Types
if user has access to node then he can do all his related actions
-}
------------------------------------------------------------------------
------------------------------------------------------------------------
-- Beta Status
data Status a = TODO a | WIP a | OnTest a | Beta a
data NodeAction = Documentation NodeType
| SearchBox
| Download | Upload | Refresh | Config
......@@ -30,18 +27,6 @@ data NodeAction = Documentation NodeType
| Clone
------------------------------------------------------------------------
-- TODO move elsewhere
data SubTreeParams = SubTreeParams { showtypes :: Array NodeType
, valitypes :: Array NodeType
}
derive instance eqSubTreeParams :: Eq SubTreeParams
derive instance genericSubTreeParams :: Generic SubTreeParams _
instance showSubTreeParams :: Show SubTreeParams where
show = genericShow
------------------------------------------------------------------------
instance eqNodeAction :: Eq NodeAction where
eq (Documentation x) (Documentation y) = true && (x == y)
eq SearchBox SearchBox = true
......
src/Gargantext/Components/Forest/Tree/Node/Status.purs 0 → 100644
View file @ f844290a
module Gargantext.Components.Forest.Tree.Node.Status where
import Gargantext.Types
import Gargantext.Components.Forest.Tree.Node.Settings (NodeAction(..))
------------------------------------------------------------------------
-- Beta Status
data Status = Stable | Test | Dev
hasStatus :: NodeType -> NodeAction -> Status
hasStatus _ SearchBox = Dev
hasStatus _ Refresh = Dev
hasStatus _ Config = Dev
hasStatus _ (Link _) = Dev
hasStatus _ (Merge _) = Dev
hasStatus _ (Move _) = Test
hasStatus _ (Documentation _) = Dev
hasStatus Annuaire Upload = Dev
hasStatus Texts Upload = Dev
hasStatus _ _ = Stable
src/Gargantext/Components/Forest/Tree/Node/Tools.purs
View file @ f844290a
......@@ -2,14 +2,18 @@ module Gargantext.Components.Forest.Tree.Node.Tools
where
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import Data.Set as Set
import Data.String as S
import Data.Tuple.Nested ((/\))
import Gargantext.Types (Name)
import Effect (Effect)
import Effect.Aff (Aff, launchAff)
import Effect.Uncurried (mkEffectFn1)
import Gargantext.Components.Forest.Tree.Node.Action
import Gargantext.Prelude (Unit, bind, const, discard, pure, show, ($), (<<<), (<>), read, map, class Read, class Show)
import Gargantext.Prelude (Unit, bind, const, discard, pure, show, ($), (<<<), (<>), read, map, class Read, class Show, not, class Ord)
import Gargantext.Types (ID)
import Gargantext.Utils (toggleSet)
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Reactix.DOM.HTML as H
......@@ -28,10 +32,9 @@ panel bodies submit =
[ H.div { className: "row"
, style: {"margin":"10px"}
}
[ H.div { className: "col-md-10" }
[ H.div { className: "col-md-12" } bs
-- TODO add type for text or form here
[ H.form {className: "form-horizontal"} bs
]
-- [ H.form {className: "form-horizontal"} bs ]
]
]
footer sb =
......@@ -201,7 +204,65 @@ submitButtonHref action href =
}
[ H.text $ " " <> text action]
------------------------------------------------------------------------
-- | CheckBox tools
-- checkboxes: Array of poolean values (basic: without pending option)
-- checkbox : One boolean value only
checkbox :: R.State Boolean -> R.Element
checkbox ( val /\ set ) =
H.input { id: "checkbox-id"
, type: "checkbox"
, value: val
, className : "checkbox"
, on: { click: \_ -> set $ const $ not val}
}
data CheckBoxes = Multiple | Uniq
checkboxes :: forall a
. Ord a
=> Show a
=> Array a
-> R.State (Set a)
-> R.Element
checkboxes xs (val /\ set) =
H.fieldset {} $ map (\a -> H.div {} [ H.input { type: "checkbox"
, checked: Set.member a val
, on: { click: \_ -> set
$ const
$ toggleSet a val
}
}
, H.div {} [H.text $ show a]
]
) xs
-- START node text
type NodeTextProps =
( isSelected :: Boolean
, name :: Name
)
nodeText :: Record NodeTextProps -> R.Element
nodeText p = R.createElement nodeTextCpt p []
nodeTextCpt :: R.Component NodeTextProps
nodeTextCpt = R.hooksComponent "G.C.F.T.N.B.nodeText" cpt
where
cpt { isSelected: true, name } _ = do
pure $ H.u {} [
H.b {} [
H.text ("| " <> name <> " | ")
]
]
cpt {isSelected: false, name} _ = do
pure $ H.text (name <> " ")
-- END node text
------------------------------------------------------------------------
divider :: R.Element
divider = H.div {className:"divider"} []
src/Gargantext/Components/Forest/Tree/Node/Tools/SubTree.purs
View file @ f844290a
module Gargantext.Components.Forest.Tree.Node.Tools.SubTree where
import DOM.Simple.Console (log2)
import Data.Array as A
import Data.Maybe (Maybe(..))
import Data.Tuple.Nested ((/\))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Effect.Uncurried (mkEffectFn1)
import Effect.Aff (Aff, launchAff)
import Gargantext.Components.Forest.Tree.Node.Action (Props, Action(..))
import Gargantext.Components.Forest.Tree.Node.Settings (SubTreeParams(..))
import Effect.Aff (Aff)
import Gargantext.Components.Forest.Tree.Node.Action (Props, Action, subTreeOut, setTreeOut)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree.Types (SubTreeParams(..), SubTreeOut(..))
import Gargantext.Components.Forest.Tree.Node.Tools.FTree (FTree, LNode(..), NTree(..))
import Gargantext.Components.Forest.Tree.Node.Tools (nodeText)
import Gargantext.Hooks.Loader (useLoader)
import Gargantext.Prelude (discard, map, pure, show, unit, ($), (&&), (/=), (<>), class Eq, const)
import Gargantext.Prelude (map, pure, show, ($), (&&), (/=), (<>), const, (==){-, discard, bind, void-})
import Gargantext.Routes as GR
import Gargantext.Sessions (Session(..), get)
import Gargantext.Types as GT
import Reactix as R
import Reactix.DOM.HTML as H
type SubTreeParamsIn =
( subTreeParams :: SubTreeParams
| Props
)
------------------------------------------------------------------------
data SubTreeOut = SubTreeOut { in :: GT.ID
, out :: GT.ID
}
------------------------------------------------------------------------
type SubTreeParamsProps =
( subTreeOut :: R.State (Maybe SubTreeOut)
( action :: R.State Action
| SubTreeParamsIn
)
......@@ -46,10 +39,13 @@ subTreeViewCpt = R.hooksComponent "G.C.F.T.N.A.U.subTreeView" cpt
, nodeType
, session
, subTreeParams
, subTreeOut
, action
} _ =
do
let SubTreeParams {showtypes} = subTreeParams
let
SubTreeParams {showtypes} = subTreeParams
-- (valAction /\ setAction) = action
-- _ <- pure $ setAction (const $ setTreeOut valAction Nothing)
useLoader session (loadSubTree showtypes) $
\tree ->
......@@ -59,7 +55,7 @@ subTreeViewCpt = R.hooksComponent "G.C.F.T.N.A.U.subTreeView" cpt
, session
, tree
, subTreeParams
, subTreeOut
, action
}
loadSubTree :: Array GT.NodeType -> Session -> Aff FTree
......@@ -85,9 +81,11 @@ subTreeViewLoadedCpt :: R.Component CorpusTreeProps
subTreeViewLoadedCpt = R.hooksComponent "G.C.F.T.N.A.U.subTreeViewLoadedCpt" cpt
where
cpt p@{dispatch, id, nodeType, session, tree} _ = do
pure $ H.div { className: "copy-from-corpus" }
[ H.div { className: "tree" }
[subTreeTreeView p]
pure $ H.div {className:"panel panel-primary"}
[H.div { className: "copy-from-corpus" }
[ H.div { className: "tree" }
[subTreeTreeView p]
]
]
subTreeTreeView :: Record CorpusTreeProps -> R.Element
......@@ -97,37 +95,48 @@ subTreeTreeViewCpt :: R.Component CorpusTreeProps
subTreeTreeViewCpt = R.hooksComponent "G.C.F.T.N.A.U.subTreeTreeViewCpt" cpt
where
cpt p@{ id
, tree: NTree (LNode { id: sourceId
, tree: NTree (LNode { id: targetId
, name
, nodeType
}
) ary
, subTreeParams
, dispatch
, subTreeOut
, action
} _ = do
pure $ {- H.div {} [ H.h5 { className: GT.fldr nodeType true} []
, -} H.div { className: "node" }
( [ H.span { className: "name " <> clickable
, on: { click: onClick }
} [ H.text name ]
] <> children
)
-- ]
pure $ H.div {} [ H.div { className: "node " <> GT.fldr nodeType true}
( [ H.span { className: "name " <> clickable
, on: { click: onClick }
} [ nodeText { isSelected: isSelected targetId valAction
, name: " " <> name
}
]
] <> children
)
]
where
SubTreeParams { valitypes } = subTreeParams
sortedAry = A.sortWith (\(NTree (LNode {id:id'}) _) -> id') ary
children = map (\c -> subTreeTreeView (p { tree = c })) ary
children = map (\ctree -> subTreeTreeView (p { tree = ctree })) sortedAry
validNodeType = (A.elem nodeType valitypes) && (id /= sourceId)
validNodeType = (A.elem nodeType valitypes) && (id /= targetId)
clickable = if validNodeType then "clickable" else ""
( valAction /\ setAction) = action
isSelected n action' = case (subTreeOut action') of
Nothing -> false
(Just (SubTreeOut {out})) -> n == out
clickable = if validNodeType then "clickable" else ""
sbto@( subTreeOutParams /\ setSubTreeOut) = subTreeOut
onClick _ = mkEffectFn1 $ \_ -> case validNodeType of
false -> setSubTreeOut (const Nothing)
true -> setSubTreeOut (const $ Just $ SubTreeOut { in: id, out:sourceId})
false -> setAction (const $ setTreeOut valAction Nothing)
true -> setAction (const $ setTreeOut valAction (Just $ SubTreeOut { in: id, out:targetId}))
--------------------------------------------------------------------------------------------
src/Gargantext/Components/Forest/Tree/Node/Tools/SubTree/Types.purs 0 → 100644
View file @ f844290a
module Gargantext.Components.Forest.Tree.Node.Tools.SubTree.Types where
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Show (genericShow)
import Gargantext.Prelude (class Eq, class Show)
import Gargantext.Types as GT
import Reactix as R
data SubTreeOut = SubTreeOut { in :: GT.ID
, out :: GT.ID
}
------------------------------------------------------------------------
data SubTreeParams = SubTreeParams { showtypes :: Array GT.NodeType
, valitypes :: Array GT.NodeType
}
derive instance eqSubTreeParams :: Eq SubTreeParams
derive instance genericSubTreeParams :: Generic SubTreeParams _
instance showSubTreeParams :: Show SubTreeParams where
show = genericShow
------------------------------------------------------------------------
src/Gargantext/Components/GraphExplorer/Sidebar.purs
View file @ f844290a
......@@ -187,7 +187,7 @@ deleteNode termList session (GET.MetaData metaData) node = NTC.putNgramsPatches
np :: NTC.NgramsPatches
np = NTC.singletonPatchMap term $ NTC.NgramsPatch { patch_children: mempty, patch_list }
patch_list :: NTC.Replace TermList
patch_list = NTC.Replace { new: termList, old: GraphTerm }
patch_list = NTC.Replace { new: termList, old: MapTerm }
query :: Frontends -> GET.MetaData -> Session -> SigmaxT.NodesMap -> R.State SigmaxT.NodeIds -> R.Element
......
src/Gargantext/Components/Login.purs
View file @ f844290a
......@@ -19,6 +19,7 @@ import Reactix as R
import Reactix.DOM.HTML as H
------------------------------------------------------------------------
import Gargantext.Components.Forest.Tree.Node.Tools (checkbox)
import Gargantext.Components.Forms (clearfix, cardBlock, cardGroup, center, formGroup)
import Gargantext.Components.Login.Types (AuthRequest(..))
import Gargantext.Ends (Backend(..))
......@@ -178,7 +179,7 @@ formCpt = R.hooksComponent "G.C.Login.form" cpt where
, center
[ H.label {}
[ H.div {className: "checkbox"}
[ termsCheckbox setBox
[ checkbox setBox
, H.text "I hereby accept "
, H.a { target: "_blank"
, href: "http://gitlab.iscpif.fr/humanities/tofu/tree/master"
......@@ -213,15 +214,6 @@ csrfTokenInput _ =
, value: csrfMiddlewareToken
} -- TODO hard-coded CSRF token
termsCheckbox :: R.State Boolean -> R.Element
termsCheckbox setCheckBox =
H.input { id: "terms-accept"
, type: "checkbox"
, value: fst setCheckBox
, className: "checkbox"
, on: { click: \_ -> (snd setCheckBox) $ const $ not (fst setCheckBox)}
}
termsLink :: {} -> R.Element
termsLink _ =
H.a { target: "_blank", href: termsUrl } [ H.text "the terms of use" ]
......
src/Gargantext/Components/NgramsTable.purs
View file @ f844290a
......@@ -257,7 +257,7 @@ tableContainerCpt { dispatch
selectButtons true =
H.div {} [
H.button { className: "btn btn-primary"
, on: { click: const $ setSelection GraphTerm }
, on: { click: const $ setSelection MapTerm }
} [ H.text "Map" ]
, H.button { className: "btn btn-primary"
, on: { click: const $ setSelection StopTerm }
......
src/Gargantext/Components/NgramsTable/Components.purs
View file @ f844290a
......@@ -183,7 +183,7 @@ renderNgramsItemCpt = R.hooksComponent "G.C.NT.renderNgramsItem" cpt
, ngramsTable } _ =
pure $ Tbl.makeRow [
selected
, checkbox T.GraphTerm
, checkbox T.MapTerm
, checkbox T.StopTerm
, if ngramsParent == Nothing
then renderNgramsTree { ngramsTable, ngrams, ngramsStyle, ngramsClick, ngramsEdit }
......@@ -232,7 +232,7 @@ renderNgramsItemCpt = R.hooksComponent "G.C.NT.renderNgramsItem" cpt
termStyle :: T.TermList -> Number -> DOM.Props
termStyle T.GraphTerm opacity = DOM.style { color: "green", opacity }
termStyle T.MapTerm opacity = DOM.style { color: "green", opacity }
termStyle T.StopTerm opacity = DOM.style { color: "red", opacity
, textDecoration: "line-through" }
termStyle T.CandidateTerm opacity = DOM.style { color: "black", opacity }
......@@ -250,6 +250,6 @@ tablePatchHasNgrams ngramsTablePatch ngrams =
nextTermList :: T.TermList -> T.TermList
nextTermList T.GraphTerm = T.StopTerm
nextTermList T.MapTerm = T.StopTerm
nextTermList T.StopTerm = T.CandidateTerm
nextTermList T.CandidateTerm = T.GraphTerm
nextTermList T.CandidateTerm = T.MapTerm
src/Gargantext/Components/NgramsTable/Core.purs
View file @ f844290a
......@@ -133,7 +133,7 @@ initialPageParams session nodeId listIds tabType =
, params
, tabType
, termSizeFilter: Nothing
, termListFilter: Just GraphTerm
, termListFilter: Just MapTerm
, searchQuery: ""
, scoreType: Occurrences
, session
......
src/Gargantext/Components/Nodes/Corpus/Chart/Common.purs
View file @ f844290a
......@@ -9,7 +9,7 @@ import Reactix as R
import Gargantext.Prelude
import Gargantext.Components.Nodes.Corpus.Chart.Types
import Gargantext.Hooks.Loader (useLoader, useLoaderWithCache)
import Gargantext.Hooks.Loader (HashedResponse, useLoader, useLoaderWithCache)
import Gargantext.Sessions (Session)
type MetricsLoadViewProps a = (
......@@ -24,23 +24,27 @@ metricsLoadView p = R.createElement metricsLoadViewCpt p []
metricsLoadViewCpt :: forall a. R.Component (MetricsLoadViewProps a)
metricsLoadViewCpt = R.hooksComponent "G.C.N.C.C.metricsLoadView" cpt
where
cpt {getMetrics, loaded, path, reload, session} _ = do
cpt { getMetrics, loaded, path, reload, session } _ = do
useLoader (fst reload /\ path) (getMetrics session) $ \l ->
loaded session path reload l
type MetricsWithCacheLoadViewProps a = (
--keyFunc :: Record Path -> String
| MetricsLoadViewProps a
keyFunc :: Tuple Reload (Record Path) -> String
, getMetrics :: Session -> Tuple Reload (Record Path) -> Aff (HashedResponse a)
, getMetricsMD5 :: Session -> Tuple Reload (Record Path) -> Aff String
, loaded :: Session -> Record Path -> R.State Reload -> a -> R.Element
| MetricsProps
)
metricsWithCacheLoadView :: forall a. DecodeJson a => EncodeJson a =>
Record (MetricsLoadViewProps a) -> R.Element
Record (MetricsWithCacheLoadViewProps a) -> R.Element
metricsWithCacheLoadView p = R.createElement metricsWithCacheLoadViewCpt p []
metricsWithCacheLoadViewCpt :: forall a. DecodeJson a => EncodeJson a => R.Component (MetricsLoadViewProps a)
metricsWithCacheLoadViewCpt :: forall a. DecodeJson a => EncodeJson a => R.Component (MetricsWithCacheLoadViewProps a)
metricsWithCacheLoadViewCpt = R.hooksComponent "G.C.N.C.C.metricsWithCacheLoadView" cpt
where
cpt {getMetrics, loaded, path, reload, session} _ = do
useLoaderWithCache (fst reload /\ path) keyFunc (getMetrics session) $ \l ->
cpt { getMetrics, getMetricsMD5, keyFunc, loaded, path, reload, session } _ = do
useLoaderWithCache (fst reload /\ path) (metricsKeyFunc keyFunc) (getMetricsMD5 session) (getMetrics session) $ \l ->
loaded session path reload l
keyFunc (_ /\ { corpusId, listId, tabType }) = "metrics-" <> (show tabType) <> "-" <> (show corpusId) <> "-" <> (show listId)
metricsKeyFunc keyFunc st@(_ /\ { corpusId, listId, tabType }) =
"metrics-" <> (show tabType) <> "-" <> (show corpusId) <> "-" <> (show listId) <> "--" <> (keyFunc st)
src/Gargantext/Components/Nodes/Corpus/Chart/Histo.purs
View file @ f844290a
......@@ -19,16 +19,19 @@ import Gargantext.Components.Charts.Options.Data (dataSerie)
import Gargantext.Components.Nodes.Corpus.Chart.Common (metricsLoadView, metricsWithCacheLoadView)
import Gargantext.Components.Nodes.Corpus.Chart.Types
import Gargantext.Components.Nodes.Corpus.Chart.Utils as U
import Gargantext.Hooks.Loader (HashedResponse(..))
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, get)
import Gargantext.Types (ChartType(..), TabType(..))
newtype ChartMetrics = ChartMetrics { "data" :: HistoMetrics }
newtype ChartMetrics = ChartMetrics {
"data" :: HistoMetrics
}
instance decodeChartMetrics :: DecodeJson ChartMetrics where
decodeJson json = do
obj <- decodeJson json
d <- obj .: "data"
d <- obj .: "data"
pure $ ChartMetrics { "data": d }
newtype HistoMetrics = HistoMetrics { dates :: Array String, count :: Array Number }
......@@ -39,7 +42,6 @@ instance decodeHistoMetrics :: DecodeJson HistoMetrics where
d <- obj .: "dates"
c <- obj .: "count"
pure $ HistoMetrics { dates : d , count: c}
instance encodeHistoMetrics :: EncodeJson HistoMetrics where
encodeJson (HistoMetrics { dates, count }) =
"count" := encodeJson count
......@@ -59,13 +61,17 @@ chartOptions (HistoMetrics { dates: dates', count: count'}) = Options
, series : [seriesBarD1 {name: "Number of publication / year"} $
map (\n -> dataSerie {value: n, itemStyle : itemStyle {color:grey}}) count'] }
getMetrics :: Session -> Tuple Reload (Record Path) -> Aff HistoMetrics
getMetrics :: Session -> Tuple Reload (Record Path) -> Aff (HashedResponse HistoMetrics)
getMetrics session (_ /\ { corpusId, limit, listId, tabType }) = do
ChartMetrics ms <- get session chart
pure ms."data"
HashedResponse { md5, value: ChartMetrics ms } <- get session chart
pure $ HashedResponse { md5, value: ms."data" }
where
chart = Chart {chartType: Histo, listId, tabType, limit} (Just corpusId)
getMetricsMD5 :: Session -> Tuple Reload (Record Path) -> Aff String
getMetricsMD5 session (_ /\ { corpusId, limit, listId, tabType }) = do
get session $ ChartMD5 { chartType: Histo, listId, tabType } (Just corpusId)
histo :: Record Props -> R.Element
histo props = R.createElement histoCpt props []
......@@ -75,7 +81,7 @@ histoCpt = R.hooksComponent "G.C.N.C.C.H.histo" cpt
cpt {path, session} _ = do
reload <- R.useState' 0
--pure $ metricsLoadView {getMetrics, loaded, path, reload, session}
pure $ metricsWithCacheLoadView {getMetrics, loaded, path, reload, session}
pure $ metricsWithCacheLoadView { getMetrics, getMetricsMD5, keyFunc: const "histo", loaded, path, reload, session }
loaded :: Session -> Record Path -> R.State Reload -> HistoMetrics -> R.Element
loaded session path reload loaded =
......
src/Gargantext/Components/Nodes/Corpus/Chart/Metrics.purs
View file @ f844290a
module Gargantext.Components.Nodes.Corpus.Chart.Metrics where
import Prelude (bind, negate, pure, ($), (<$>), (<>))
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson, (.:), (~>), (:=))
import Data.Argonaut.Core (jsonEmptyObject)
import Data.Map as Map
......@@ -8,10 +7,12 @@ import Data.Map (Map)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff)
import Effect.Aff (Aff, launchAff_)
import Reactix as R
import Reactix.DOM.HTML as H
import Gargantext.Prelude
import Gargantext.Components.Charts.Options.ECharts (Options(..), chart, yAxis')
import Gargantext.Components.Charts.Options.Type (xAxis)
import Gargantext.Components.Charts.Options.Series (Series, seriesScatterD2)
......@@ -21,6 +22,7 @@ import Gargantext.Components.Charts.Options.Data (dataSerie)
import Gargantext.Components.Nodes.Corpus.Chart.Common (metricsLoadView, metricsWithCacheLoadView)
import Gargantext.Components.Nodes.Corpus.Chart.Types
import Gargantext.Components.Nodes.Corpus.Chart.Utils as U
import Gargantext.Hooks.Loader (HashedResponse(..))
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, get)
import Gargantext.Types (ChartType(..), TabType, TermList(..))
......@@ -49,8 +51,8 @@ instance encodeMetric :: EncodeJson Metric where
~> "cat" := encodeJson cat
~> jsonEmptyObject
newtype Metrics = Metrics
{ "data" :: Array Metric
newtype Metrics = Metrics {
"data" :: Array Metric
}
instance decodeMetrics :: DecodeJson Metrics where
......@@ -86,7 +88,7 @@ scatterOptions metrics' = Options
color =
case k of
StopTerm -> red
GraphTerm -> green
MapTerm -> green
CandidateTerm -> grey
toSerie color' (Metric {label,x,y}) =
dataSerie { name: label, itemStyle: itemStyle {color: color'}
......@@ -95,13 +97,17 @@ scatterOptions metrics' = Options
}
--}
getMetrics :: Session -> Tuple Reload (Record Path) -> Aff Loaded
getMetrics :: Session -> Tuple Reload (Record Path) -> Aff (HashedResponse Loaded)
getMetrics session (_ /\ { corpusId, limit, listId, tabType }) = do
Metrics ms <- get session metrics'
pure ms."data"
HashedResponse { md5, value: Metrics ms } <- get session metrics'
pure $ HashedResponse { md5, value: ms."data" }
where
metrics' = CorpusMetrics {limit, listId, tabType} (Just corpusId)
getMetricsMD5 :: Session -> Tuple Reload (Record Path) -> Aff String
getMetricsMD5 session (_ /\ { corpusId, listId, tabType }) =
get session $ CorpusMetricsMD5 { listId, tabType } (Just corpusId)
metrics :: Record Props -> R.Element
metrics props = R.createElement metricsCpt props []
......@@ -111,7 +117,8 @@ metricsCpt = R.hooksComponent "G.C.N.C.C.M.metrics" cpt
cpt {path, session} _ = do
reload <- R.useState' 0
--pure $ metricsLoadView {getMetrics, loaded, path, reload, session}
pure $ metricsWithCacheLoadView {getMetrics, loaded, path, reload, session}
pure $ metricsWithCacheLoadView { getMetrics, getMetricsMD5, keyFunc: const "metrics", loaded, path, reload, session }
loaded :: Session -> Record Path -> R.State Reload -> Loaded -> R.Element
......
src/Gargantext/Components/Nodes/Corpus/Chart/Pie.purs
View file @ f844290a
module Gargantext.Components.Nodes.Corpus.Chart.Pie where
import Prelude (bind, map, pure, ($), (>))
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson, (.:), (~>), (:=))
import Data.Argonaut.Core (jsonEmptyObject)
import Data.Array (zip, filter)
......@@ -13,6 +12,8 @@ import Effect.Aff (Aff)
import Reactix as R
import Reactix.DOM.HTML as H
import Gargantext.Prelude
import Gargantext.Components.Charts.Options.ECharts (Options(..), chart, xAxis', yAxis')
import Gargantext.Components.Charts.Options.Series (seriesBarD1, seriesPieD1)
import Gargantext.Components.Charts.Options.Color (blue)
......@@ -21,12 +22,13 @@ import Gargantext.Components.Charts.Options.Data (dataSerie)
import Gargantext.Components.Nodes.Corpus.Chart.Common (metricsLoadView, metricsWithCacheLoadView)
import Gargantext.Components.Nodes.Corpus.Chart.Types
import Gargantext.Components.Nodes.Corpus.Chart.Utils as U
import Gargantext.Hooks.Loader (HashedResponse(..))
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, get)
import Gargantext.Types (ChartType(..), TabType)
newtype ChartMetrics = ChartMetrics
{ "data" :: HistoMetrics
newtype ChartMetrics = ChartMetrics {
"data" :: HistoMetrics
}
instance decodeChartMetrics :: DecodeJson ChartMetrics where
......@@ -58,7 +60,7 @@ type Loaded = HistoMetrics
chartOptionsBar :: HistoMetrics -> Options
chartOptionsBar (HistoMetrics { dates: dates', count: count'}) = Options
{ mainTitle : "Bar"
, subTitle : "Count of GraphTerm"
, subTitle : "Count of MapTerm"
, xAxis : xAxis' $ map (\t -> joinWith " " $ map (take 3) $ A.take 3 $ filter (\s -> length s > 3) $ split (Pattern " ") t) dates'
, yAxis : yAxis' { position: "left", show: true, min:0}
, series : [seriesBarD1 {name: "Number of publication / year"} $ map (\n -> dataSerie {name: "", itemStyle: itemStyle {color:blue}, value: n }) count']
......@@ -69,7 +71,7 @@ chartOptionsBar (HistoMetrics { dates: dates', count: count'}) = Options
chartOptionsPie :: HistoMetrics -> Options
chartOptionsPie (HistoMetrics { dates: dates', count: count'}) = Options
{ mainTitle : "Pie"
, subTitle : "Distribution by GraphTerm"
, subTitle : "Distribution by MapTerm"
, xAxis : xAxis' []
, yAxis : yAxis' { position: "", show: false, min:0}
, series : [seriesPieD1 {name: "Data"} $ map (\(Tuple n v) -> dataSerie {name: n, value:v}) $ zip dates' count']
......@@ -79,12 +81,16 @@ chartOptionsPie (HistoMetrics { dates: dates', count: count'}) = Options
}
getMetrics :: Session -> Tuple Reload (Record Path) -> Aff HistoMetrics
getMetrics :: Session -> Tuple Reload (Record Path) -> Aff (HashedResponse HistoMetrics)
getMetrics session (_ /\ { corpusId, limit, listId, tabType }) = do
ChartMetrics ms <- get session chart
pure ms."data"
HashedResponse { md5, value: ChartMetrics ms } <- get session chart
pure $ HashedResponse { md5, value: ms."data" }
where chart = Chart {chartType: ChartPie, limit, listId, tabType} (Just corpusId)
getMetricsMD5 :: Session -> Tuple Reload (Record Path) -> Aff String
getMetricsMD5 session (_ /\ { corpusId, limit, listId, tabType }) = do
get session $ ChartMD5 { chartType: ChartPie, listId, tabType } (Just corpusId)
pie :: Record Props -> R.Element
pie props = R.createElement pieCpt props []
......@@ -94,7 +100,7 @@ pieCpt = R.hooksComponent "G.C.N.C.C.P.pie" cpt
cpt {path,session} _ = do
reload <- R.useState' 0
--pure $ metricsLoadView {getMetrics, loaded: loadedPie, path, reload, session}
pure $ metricsWithCacheLoadView {getMetrics, loaded: loadedPie, path, reload, session}
pure $ metricsWithCacheLoadView { getMetrics, getMetricsMD5, keyFunc: const "pie", loaded: loadedPie, path, reload, session }
loadedPie :: Session -> Record Path -> R.State Reload -> HistoMetrics -> R.Element
loadedPie session path reload loaded =
......@@ -114,7 +120,7 @@ barCpt = R.hooksComponent "LoadedMetricsBar" cpt
cpt {path, session} _ = do
reload <- R.useState' 0
--pure $ metricsLoadView {getMetrics, loaded: loadedBar, path, reload, session}
pure $ metricsWithCacheLoadView {getMetrics, loaded: loadedBar, path, reload, session}
pure $ metricsWithCacheLoadView { getMetrics, getMetricsMD5, keyFunc: const "bar", loaded: loadedBar, path, reload, session }
loadedBar :: Session -> Record Path -> R.State Reload -> Loaded -> R.Element
loadedBar session path reload loaded =
......
src/Gargantext/Components/Nodes/Corpus/Chart/Predefined.purs
View file @ f844290a
......@@ -12,10 +12,8 @@ import Gargantext.Components.Nodes.Corpus.Chart.Histo (histo)
import Gargantext.Components.Nodes.Corpus.Chart.Metrics (metrics)
import Gargantext.Components.Nodes.Corpus.Chart.Pie (pie)
import Gargantext.Components.Nodes.Corpus.Chart.Tree (tree)
import Gargantext.Prelude
import Gargantext.Sessions (Session)
import Gargantext.Types (NodeID, Mode(..), TabSubType(..), TabType(..), modeTabType)
import Reactix as R
data PredefinedChart =
......
src/Gargantext/Components/Nodes/Corpus/Chart/Tree.purs
View file @ f844290a
......@@ -17,12 +17,13 @@ import Gargantext.Components.Charts.Options.Font (mkTooltip, templateFormatter)
import Gargantext.Components.Nodes.Corpus.Chart.Utils as U
import Gargantext.Components.Nodes.Corpus.Chart.Common (metricsLoadView, metricsWithCacheLoadView)
import Gargantext.Components.Nodes.Corpus.Chart.Types
import Gargantext.Hooks.Loader (HashedResponse(..))
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, get)
import Gargantext.Types (ChartType(..), TabType)
newtype Metrics = Metrics
{ "data" :: Array TreeNode
newtype Metrics = Metrics {
"data" :: Array TreeNode
}
instance decodeMetrics :: DecodeJson Metrics where
......@@ -30,7 +31,6 @@ instance decodeMetrics :: DecodeJson Metrics where
obj <- decodeJson json
d <- obj .: "data"
pure $ Metrics { "data": d }
instance encodeMetrics :: EncodeJson Metrics where
encodeJson (Metrics { "data": d }) =
"data" := encodeJson d
......@@ -52,13 +52,17 @@ scatterOptions nodes = Options
}
getMetrics :: Session -> Tuple Reload (Record Path) -> Aff Loaded
getMetrics :: Session -> Tuple Reload (Record Path) -> Aff (HashedResponse Loaded)
getMetrics session (_ /\ { corpusId, limit, listId, tabType }) = do
Metrics ms <- get session chart
pure ms."data"
HashedResponse { md5, value: Metrics ms } <- get session chart
pure $ HashedResponse { md5, value: ms."data" }
where
chart = Chart {chartType : ChartTree, limit, listId, tabType} (Just corpusId)
getMetricsMD5 :: Session -> Tuple Reload (Record Path) -> Aff String
getMetricsMD5 session (_ /\ { corpusId, limit, listId, tabType }) = do
get session $ ChartMD5 { chartType: ChartTree, listId, tabType } (Just corpusId)
tree :: Record Props -> R.Element
tree props = R.createElement treeCpt props []
......@@ -68,7 +72,7 @@ treeCpt = R.hooksComponent "G.C.N.C.C.T.tree" cpt
cpt {path, session} _ = do
reload <- R.useState' 0
--pure $ metricsLoadView {getMetrics, loaded, path, reload, session}
pure $ metricsWithCacheLoadView {getMetrics, loaded, path, reload, session}
pure $ metricsWithCacheLoadView { getMetrics, getMetricsMD5, keyFunc: const "tree", loaded, path, reload, session }
loaded :: Session -> Record Path -> R.State Reload -> Loaded -> R.Element
loaded session path reload loaded =
......
src/Gargantext/Ends.purs
View file @ f844290a
......@@ -120,7 +120,7 @@ sessionPath (R.NodeAPI Phylo pId p) = "phyloscape?nodeId=" <> (show $ fromMaybe
sessionPath (R.RecomputeNgrams nt nId lId) = "node/" <> (show nId) <> "/ngrams/recompute?list=" <> (show lId) <> "&ngramsType=" <> (show nt)
sessionPath (R.RecomputeListChart ChartBar nt nId lId) = "node/" <> (show nId) <> "/pie?list=" <> (show lId) <> "&ngramsType=" <> (show nt)
sessionPath (R.RecomputeListChart ChartPie nt nId lId) = "node/" <> (show nId) <> "/pie?list=" <> (show lId) <> "&ngramsType=" <> (show nt)
sessionPath (R.RecomputeListChart ChartTree nt nId lId) = "node/" <> (show nId) <> "/tree?list=" <> (show lId) <> "&ngramsType=" <> (show nt) <> "&listType=GraphTerm"
sessionPath (R.RecomputeListChart ChartTree nt nId lId) = "node/" <> (show nId) <> "/tree?list=" <> (show lId) <> "&ngramsType=" <> (show nt) <> "&listType=MapTerm"
sessionPath (R.RecomputeListChart Histo nt nId lId) = "node/" <> (show nId) <> "/chart?list=" <> (show lId) <> "&ngramsType=" <> (show nt)
sessionPath (R.RecomputeListChart Scatter nt nId lId) = "node/" <> (show nId) <> "/metrics?list=" <> (show lId) <> "&ngramsType=" <> (show nt)
sessionPath (R.RecomputeListChart _ nt nId lId) = "node/" <> (show nId) <> "/recompute-chart?list=" <> (show lId) <> "&ngramsType=" <> (show nt)
......@@ -185,18 +185,29 @@ sessionPath (R.CorpusMetrics { listId, limit, tabType} i) =
<> "?ngrams=" <> show listId
<> "&ngramsType=" <> showTabType' tabType
<> maybe "" limitUrl limit
sessionPath (R.CorpusMetricsMD5 { listId, tabType} i) =
sessionPath $ R.NodeAPI Corpus i
$ "metrics/md5"
<> "?ngrams=" <> show listId
<> "&ngramsType=" <> showTabType' tabType
-- TODO fix this url path
sessionPath (R.Chart {chartType, listId, limit, tabType} i) =
sessionPath $ R.NodeAPI Corpus i
$ show chartType
<> "?ngramsType=" <> showTabType' tabType
<> "&listType=GraphTerm" -- <> show listId
<> "&listType=MapTerm" -- <> show listId
<> "&listId=" <> show listId
where
limitPath = case limit of
Just li -> "&limit=" <> show li
Nothing -> ""
-- <> maybe "" limitUrl limit
sessionPath (R.ChartMD5 { chartType, listId, tabType } i) =
sessionPath $ R.NodeAPI Corpus i
$ show chartType
<> "/md5?ngramsType=" <> showTabType' tabType
<> "&listType=GraphTerm" -- <> show listId
<> "&listId=" <> show listId
-- sessionPath (R.NodeAPI (NodeContact s a i) i) = sessionPath $ "annuaire/" <> show a <> "/contact/" <> show i
------- misc routing stuff
......
src/Gargantext/Hooks/Loader.purs
View file @ f844290a
module Gargantext.Hooks.Loader where
import Gargantext.Prelude
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson, (.:), (:=), (~>), jsonEmptyObject)
import Data.Argonaut.Core (stringify)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either(..))
......@@ -9,7 +9,7 @@ import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Tuple (fst)
import Data.Tuple.Nested ((/\))
import DOM.Simple.Console (log2)
import Effect.Aff (Aff)
import Effect.Aff (Aff, launchAff_)
import Effect.Class (liftEffect)
import Reactix as R
import Web.Storage.Storage as WSS
......@@ -44,48 +44,93 @@ useLoaderEffect path state@(state' /\ setState) loader = do
liftEffect $ setState $ const $ Just l
newtype HashedResponse a = HashedResponse {
md5 :: String
, value :: a
}
instance decodeHashedResponse :: DecodeJson a => DecodeJson (HashedResponse a) where
decodeJson json = do
obj <- decodeJson json
md5 <- obj .: "md5"
value <- obj .: "value"
pure $ HashedResponse { md5, value }
instance encodeHashedResponse :: EncodeJson a => EncodeJson (HashedResponse a) where
encodeJson (HashedResponse { md5, value }) = do
"md5" := encodeJson md5
~> "value" := encodeJson value
~> jsonEmptyObject
useLoaderWithCache :: forall path st. Eq path => DecodeJson st => EncodeJson st =>
path
-> (path -> String)
-> (path -> Aff st)
-> (path -> Aff String)
-> (path -> Aff (HashedResponse st))
-> (st -> R.Element) -> R.Hooks R.Element
useLoaderWithCache path keyFunc loader render = do
useLoaderWithCache path keyFunc md5Endpoint loader render = do
state <- R.useState' Nothing
useCachedLoaderEffect path keyFunc state loader
useCachedLoaderEffect path keyFunc md5Endpoint state loader
pure $ maybe (loadingSpinner {}) render (fst state)
useCachedLoaderEffect :: forall path st. Eq path => DecodeJson st => EncodeJson st =>
path
-> (path -> String)
-> (path -> Aff String)
-> R.State (Maybe st)
-> (path -> Aff st)
-> (path -> Aff (HashedResponse st))
-> R.Hooks Unit
useCachedLoaderEffect path keyFunc state@(state' /\ setState) loader = do
useCachedLoaderEffect path keyFunc md5Endpoint state@(state' /\ setState) loader = do
oPath <- R.useRef path
R.useEffect' $ do
if (R.readRef oPath == path) && (isJust state') then
pure $ pure unit
pure unit
else do
R.setRef oPath path
let key = keyFunc path
let key = "loader--" <> (keyFunc path)
-- log2 "[useCachedLoader] key" key
let keyMD5 = key <> "-md5"
localStorage <- R2.getls
mState <- WSS.getItem key localStorage
case mState of
Nothing -> pure unit
Just stStr ->
case (parse stStr >>= decode) of
Left err -> pure unit
Right st -> setState $ const $ Just st
R2.affEffect "G.H.Loader.useCachedLoaderEffect" $ do
l <- loader path
liftEffect $ do
let value = stringify $ encodeJson l
WSS.setItem key value localStorage
setState $ const $ Just l
mMD5 <- WSS.getItem keyMD5 localStorage
-- log2 "[useCachedLoader] mState" mState
launchAff_ $ do
case mState of
Nothing -> loadRealData key keyMD5 localStorage
Just stStr -> do
let parsed = parse stStr >>= decode
case parsed of
Left err -> do
-- liftEffect $ log2 "[useCachedLoader] err" err
loadRealData key keyMD5 localStorage
Right (st :: st) -> do
md5Real <- md5Endpoint path
-- liftEffect $ log2 "[useCachedLoader] md5Real" md5Real
case mMD5 of
Nothing -> do
-- liftEffect $ log2 "[useCachedLoader] no stored md5" Nothing
loadRealData key keyMD5 localStorage
Just md5 -> do
-- liftEffect $ log2 "[useCachedLoader] stored md5" md5
if md5 == md5Real then
-- yay! cache hit!
liftEffect $ setState $ const $ Just st
else
loadRealData key keyMD5 localStorage
where
parse s = GU.mapLeft (log2 "Error parsing serialised sessions:") (jsonParser s)
decode j = GU.mapLeft (log2 "Error decoding serialised sessions:") (decodeJson j)
loadRealData :: String -> String -> WSS.Storage -> Aff Unit
loadRealData key keyMD5 localStorage = do
--R2.affEffect "G.H.Loader.useCachedLoaderEffect" $ do
HashedResponse { md5, value: l } <- loader path
liftEffect $ do
let value = stringify $ encodeJson l
WSS.setItem key value localStorage
WSS.setItem keyMD5 md5 localStorage
setState $ const $ Just l
pure unit
parse s = GU.mapLeft (\err -> "Error parsing serialised sessions:" <> show err) (jsonParser s)
decode j = GU.mapLeft (\err -> "Error decoding serialised sessions:" <> show err) (decodeJson j)
src/Gargantext/Routes.purs
View file @ f844290a
......@@ -44,7 +44,9 @@ data SessionRoute
| ListDocument (Maybe ListId) (Maybe Id)
| Search SearchOpts (Maybe Id)
| CorpusMetrics CorpusMetricOpts (Maybe Id)
| CorpusMetricsMD5 { listId :: ListId, tabType :: TabType } (Maybe Id)
| Chart ChartOpts (Maybe Id)
| ChartMD5 { chartType :: ChartType, listId :: ListId, tabType :: TabType } (Maybe Id)
instance showAppRoute :: Show AppRoute where
show Home = "Home"
......
src/Gargantext/Types.purs
View file @ f844290a
......@@ -10,7 +10,7 @@ import Data.Generic.Rep.Show (genericShow)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Effect.Aff (Aff)
import Gargantext.Prelude (class Read, read)
import Gargantext.Prelude (class Read, read, class Show, show)
import Prelude
import Prim.Row (class Union)
import URI.Query (Query)
......@@ -56,14 +56,14 @@ termSizes = [ { desc: "All types", mval: Nothing }
, { desc: "Multi-word terms", mval: Just MultiTerm }
]
data TermList = GraphTerm | StopTerm | CandidateTerm
data TermList = MapTerm | StopTerm | CandidateTerm
-- TODO use generic JSON instance
derive instance eqTermList :: Eq TermList
derive instance ordTermList :: Ord TermList
instance encodeJsonTermList :: EncodeJson TermList where
encodeJson GraphTerm = encodeJson "GraphTerm"
encodeJson MapTerm = encodeJson "MapTerm"
encodeJson StopTerm = encodeJson "StopTerm"
encodeJson CandidateTerm = encodeJson "CandidateTerm"
......@@ -71,7 +71,7 @@ instance decodeJsonTermList :: DecodeJson TermList where
decodeJson json = do
s <- decodeJson json
case s of
"GraphTerm" -> pure GraphTerm
"MapTerm" -> pure MapTerm
"StopTerm" -> pure StopTerm
"CandidateTerm" -> pure CandidateTerm
_ -> Left "Unexpected list name"
......@@ -79,31 +79,31 @@ instance decodeJsonTermList :: DecodeJson TermList where
type ListTypeId = Int
listTypeId :: TermList -> ListTypeId
listTypeId GraphTerm = 1
listTypeId MapTerm = 1
listTypeId StopTerm = 2
listTypeId CandidateTerm = 3
instance showTermList :: Show TermList where
show GraphTerm = "GraphTerm"
show MapTerm = "MapTerm"
show StopTerm = "StopTerm"
show CandidateTerm = "CandidateTerm"
-- TODO: Can we replace the show instance above with this?
termListName :: TermList -> String
termListName GraphTerm = "Map List"
termListName MapTerm = "Map List"
termListName StopTerm = "Stop List"
termListName CandidateTerm = "Candidate List"
instance readTermList :: Read TermList where
read :: String -> Maybe TermList
read "GraphTerm" = Just GraphTerm
read "MapTerm" = Just MapTerm
read "StopTerm" = Just StopTerm
read "CandidateTerm" = Just CandidateTerm
read _ = Nothing
termLists :: Array { desc :: String, mval :: Maybe TermList }
termLists = [ { desc: "All terms", mval: Nothing }
, { desc: "Map terms", mval: Just GraphTerm }
, { desc: "Map terms", mval: Just MapTerm }
, { desc: "Stop terms", mval: Just StopTerm }
, { desc: "Candidate terms", mval: Just CandidateTerm }
]
......
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