Skip to content

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

Merge branch 'dev' into dev-list-charts

parents 16364b1e 8c872d4b
Hide whitespace changes
Inline Side-by-side
Showing with 2540 additions and 1857 deletions
README.md
View file @ 0b03d8c1
......@@ -14,15 +14,14 @@ granted access to a [backend](https://gitlab.iscpif.fr/gargantext/haskell-gargan
This software is free software, developed by the CNRS Complex Systems
Institute of Paris Île-de-France (ISC-PIF) and its partners.
## Development
## Dependencies
### System Dependencies
The build requires the following system dependencies preinstalled:
* NodeJS (11+)
* Yarn (Recent)
* A webserver (anything that can serve a static directory will do)
#### NodeJS Installation
### NodeJS
On debian testing, debian unstable or ubuntu:
......@@ -37,32 +36,28 @@ curl -sL https://deb.nodesource.com/setup_11.x | sudo bash -
sudo apt update && sudo apt install nodejs
```
(For Ubuntu)
```shell
curl -sS https://dl.yarnpkg.com/debian/pubkey.gpg | sudo apt-key add -
echo "deb https://dl.yarnpkg.com/debian/ stable main" | sudo tee /etc/apt/sources.list.d/yarn.list
sudo apt update && sudo apt install yarn
```
To upgrade to latest version (and not current stable) version, you can use
(Use n module from npm in order to upgrade node)
<!-- TODO: wtf is all this sudo? -->
<!-- To upgrade to latest version (and not current stable) version, you can -->
<!-- use the `n` module from npm to upgrade node: -->
```shell
sudo npm cache clean -f
sudo npm install -g n
sudo n stable
sudo n latest
```
<!-- ```shell -->
<!-- sudo npm cache clean -f -->
<!-- sudo npm install -g n -->
<!-- sudo n stable -->
<!-- sudo n latest -->
<!-- ``` -->
On Mac OS X with homebrew:
### OSX
```shell
brew install node
```
#### Yarn installation
For other platforms, please refer to [the nodejs website](https://nodejs.org/en/download/).
### Yarn (javascript package manager)
On ubuntu:
On debian or ubuntu:
```shell
curl -sS https://dl.yarnpkg.com/debian/pubkey.gpg | sudo apt-key add -
......@@ -70,113 +65,77 @@ echo "deb https://dl.yarnpkg.com/debian/ stable main" | sudo tee /etc/apt/source
sudo apt update && sudo apt install yarn
```
On Mac OS (with Homebrew):
On Mac OS X with homebrew:
```shell
brew install yarn
```
#### Webservers
Some options:
For other platforms, please refer to [the yarn website](https://www.yarnpkg.com/).
* The `python3` builtin webserver
* Caddy
### Purescript and Javascript dependencies
## Development
Once you have node and yarn installed, you may install deps with:
```shell
yarn install && yarn add psc-package && yarn install-ps && yarn build
```
You need to copy index.html:
```shell
cp src/index.html dist/
yarn install -D && yarn install-ps
```
(Be careful, to update or upgrade your install, maybe you need to remove
old files in node_modules).
### Development
You can compile the purescript code with:
You will likely want to check your work in a browser. We provide a
local development webserver that serves on port 5000 for this purpose:
```shell
yarn compile
yarn server
```
Or run a repl:
To generate a new browser bundle to test:
```shell
yarn repl
```
```shell
yarn install && yarn ps-deps
yarn build
```
### Running a dev server
If you are rapidly iterating and just want to type check your code:
```shell
yarn dev
```
This will launch a hot-reloading development server with
webpack-dev-server. Visit [localhost:9000](http://localhost:9000/) to
see the result when the output shows a line like this:
```
ℹ ｢wdm｣: Compiled successfully.
yarn compile
```
#### Purescript IDE integration
A `purs ide` connection will be available on port 9002 while the
development server is running.
A guide to getting set up with the IDE integration is beyond the scope
of this document.
#### Source maps
Currently broken. Someone please fix them.
### Getting a purescript repl
You may access a purescript repl if you want to explore:
```shell
yarn repl
```
### Compiling styles
We use the `sass` compiler for some of the style files. To convert them to CSS do:
If you need to reinstall dependencies such as after a git pull or branch switch:
```shell
yarn sass
yarn install -D && yarn install-ps # both javascript and purescript
```
### Building for production
If something goes wrong building after a deps update, you may clean
build artifacts and try again:
```shell
yarn build
yarn clean-js # clean javascript, very useful
yarn clean-ps # clean purescript, should never be required, possible purescript bug
yarn clean # clean both purescript and javascript
```
It is *not* necessary to `yarn compile` before running `yarn build`.
If you edit the SASS, you'll need to rebuild the CSS:
You can then serve the `dist` directory with your favourite webserver.
Examples:
```shell
yarn sass
```
* `python3 -m http.server --directory dist` (requires Python 3.7+)
<!-- A `purs ide` connection will be available on port 9002 while the -->
<!-- development server is running. -->
<!-- To get a live-reloading development server -->
A guide to getting set up with the IDE integration is coming soon, I hope.
of this document.
<!-- ```shell -->
<!-- yarn live -->
<!-- ``` -->
### Note to contributors
Note that a production build takes a little while.
Please follow CONTRIBUTING.md
### How do I?
......@@ -194,12 +153,6 @@ endConfig' v = { front : frontRelative
, back : backDemo v }
```
## Note to the contributors
Please follow CONTRIBUTING.md
### How do I?
#### Add a javascript dependency?
Add it to `package.json`, under `dependencies` if it is needed at
......@@ -288,10 +241,9 @@ bigram/2-gram
: A two-word n-gram, e.g. `coffee cup`
trigram/3-gram
: A three-word n-gram, e.g. `coffee cup holder`
<!-- skip-grams are not yet supported -->
<!-- skip-gram -->
<!-- : An n-gram where the words are not all adjacent -->
<!-- k-skip-n-gram -->
<!-- : An n-gram where the words are at most distance k from each other -->
skip-gram
: An n-gram where the words are not all adjacent. Not yet supported.
k-skip-n-gram
: An n-gram where the words are at most distance k from each other.
dist/styles/Login.css
View file @ 0b03d8c1
......@@ -78,9 +78,10 @@ li#rename #rename-a {
background-color: white;
border: none;
}
#node-popup-tooltip .popup-container .istex-search.panel {
#node-popup-tooltip .popup-container .frame-search.panel {
border: 1px solid rgba(0, 0, 0, 0.2);
box-shadow: 0 2px 5px rgba(0, 0, 0, 0.2);
height: 600px;
width: 1300px;
}
......
dist/styles/Login.sass
View file @ 0b03d8c1
......@@ -70,9 +70,10 @@ li#rename
justify-content: center
background-color: white
border: none
.istex-search.panel
.frame-search.panel
border: 1px solid rgba(0,0,0,0.2)
box-shadow: 0 2px 5px rgba(0,0,0,0.2)
height: 600px
width: 1300px
......
package.json
View file @ 0b03d8c1
{
"name": "Gargantext",
"version": "0.0.1.5.1",
"version": "0.0.1.5.2",
"scripts": {
"rebase-set": "spago package-set-upgrade && spago psc-package-insdhall",
"rebuild-set": "spago psc-package-insdhall",
......@@ -14,7 +14,7 @@
"clean-js": "rm -Rf node_modules",
"clean-ps": "rm -Rf output",
"test": "pulp test",
"start": "serve dist"
"server": "serve dist"
},
"dependencies": {
"create-react-class": "^15.6.3",
......
src/Gargantext/AsyncTasks.purs
View file @ 0b03d8c1
module Gargantext.AsyncTasks where
import Data.Argonaut (decodeJson, class EncodeJson, encodeJson, (:=), (~>), (.:))
import Data.Argonaut (decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array as A
import Data.Either (Either(..))
......
src/Gargantext/Components/DocsTable.purs
View file @ 0b03d8c1
......@@ -34,7 +34,7 @@ import Gargantext.Utils.Reactix as R2
import Gargantext.Routes as Routes
import Gargantext.Routes (SessionRoute(NodeAPI))
import Gargantext.Sessions (Session, sessionId, post, delete, put)
import Gargantext.Types (NodeType(..), OrderBy(..), TabType, TabPostQuery(..), AffTableResult, NodeID)
import Gargantext.Types (NodeType(..), OrderBy(..), TabType, TabPostQuery(..), AffTableResult)
------------------------------------------------------------------------
data Category = Trash | UnRead | Checked | Topic | Favorite
......
src/Gargantext/Components/Forest.purs
View file @ 0b03d8c1
......@@ -33,27 +33,45 @@ forestCpt :: R.Component Props
forestCpt = R.hooksComponent "G.C.Forest.forest" cpt where
cpt { frontends, reload: extReload, route, sessions, showLogin } _ = do
-- NOTE: this is a hack to reload the tree view on demand
reload <- R.useState' (0 :: Reload)
openNodes <- R2.useLocalStorageState R2.openNodesKey (Set.empty :: OpenNodes)
reload <- R.useState' (0 :: Reload)
openNodes <- R2.useLocalStorageState R2.openNodesKey (Set.empty :: OpenNodes)
asyncTasks <- R2.useLocalStorageState GAT.localStorageKey GAT.empty
R2.useCache
(frontends /\ route /\ sessions /\ fst openNodes /\ fst extReload /\ fst reload /\ fst asyncTasks)
( frontends
/\ route
/\ sessions
/\ fst openNodes
/\ fst extReload
/\ fst reload
/\ fst asyncTasks
)
(cpt' openNodes asyncTasks reload showLogin)
cpt' openNodes asyncTasks reload showLogin (frontends /\ route /\ sessions /\ _ /\ _ /\ _ /\ _) = do
pure $ R.fragment $ A.cons (plus showLogin) trees
where
trees = tree <$> unSessions sessions
tree s@(Session {treeId}) =
treeView { root: treeId, asyncTasks, frontends, mCurrentRoute: Just route, session: s, openNodes, reload }
treeView { root: treeId
, asyncTasks
, frontends
, mCurrentRoute: Just route
, session: s
, openNodes
, reload
}
plus :: R2.Setter Boolean -> R.Element
plus showLogin =
H.button {on: {click}, className: "btn btn-primary"}
[ H.div { "type": "", className: "fa fa-universal-access fa-lg"} [H.text " Log "]
, H.div {} [H.text " "]
H.button { on: {click}
, className: "btn btn-primary"
}
[ H.div { "type": ""
, className: "fa fa-universal-access fa-lg"
} [H.text " Log "]
, H.div {} [H.text " "]
--, H.div { "type": "", className: "fa fa-plus-circle fa-lg"} []
--, H.div { "type": "", className: "fa fa-minus-circle fa-lg"} []
]
]
-- TODO same as the one in the Login Modal (same CSS)
-- [ H.i { className: "material-icons md-36"} [] ]
where
......
src/Gargantext/Components/Forest/Tree.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree where
import DOM.Simple.Console (log, log2)
import Data.Array as A
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Maybe (Maybe)
import Data.Set as Set
import Data.Tuple (Tuple(..), fst, snd)
import Data.Tuple.Nested ((/\))
import DOM.Simple.Console (log2)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Reactix as R
import Reactix.DOM.HTML as H
import Record as Record
import Record.Extra as RecordE
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Forest.Tree.Node.Action (Action(..),deleteNode)
import Gargantext.Components.Forest.Tree.Node.Action.CopyFrom (loadNode)
import Gargantext.Components.Forest.Tree.Node (nodeMainSpan)
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.CopyFrom (getNodeTree)
import Gargantext.Components.Forest.Tree.Node.Action.Delete (deleteNode)
import Gargantext.Components.Forest.Tree.Node.Action.Rename (RenameValue(..), rename)
import Gargantext.Components.Forest.Tree.Node.Action.Share (ShareValue(..), share)
import Gargantext.Components.Forest.Tree.Node.Action.Update (updateRequest)
import Gargantext.Components.Forest.Tree.Node.Action.Upload (uploadFile)
import Gargantext.Components.Forest.Tree.Node.Action.Rename (RenameValue(..), renameNode)
import Gargantext.Components.Forest.Tree.Node.Box (nodeMainSpan, Tasks, tasksStruct)
import Gargantext.Components.Forest.Tree.Node.FTree (FTree, LNode(..), NTree(..), Tree)
import Gargantext.Components.Forest.Tree.Node.Tools.FTree (FTree, LNode(..), NTree(..))
import Gargantext.Components.Forest.Tree.Node.Tools.Task (Tasks, tasksStruct)
import Gargantext.Ends (Frontends)
import Gargantext.Hooks.Loader (useLoader)
import Gargantext.Prelude (Unit, bind, const, discard, map, pure, void, ($), (+), (/=), (<>), identity)
import Gargantext.Prelude (Unit, bind, discard, map, pure, void, ($), (+), (<>))
import Gargantext.Routes (AppRoute)
import Gargantext.Sessions (OpenNodes, Session, mkNodeId)
import Gargantext.Types as GT
import Gargantext.Types (ID, Reload)
import Reactix as R
import Reactix.DOM.HTML as H
import Record as Record
import Record.Extra as RecordE
------------------------------------------------------------------------
type CommonProps =
( frontends :: Frontends
, mCurrentRoute :: Maybe AppRoute
......@@ -42,8 +41,8 @@ type CommonProps =
)
------------------------------------------------------------------------
type Props = ( root :: ID
, asyncTasks :: R.State GAT.Storage
type Props = ( root :: ID
, asyncTasks :: R.State GAT.Storage
| CommonProps
)
......@@ -53,9 +52,22 @@ treeView props = R.createElement treeViewCpt props []
treeViewCpt :: R.Component Props
treeViewCpt = R.hooksComponent "G.C.Tree.treeView" cpt
where
cpt { root, mCurrentRoute, session, frontends, openNodes, reload, asyncTasks} _children = do
pure $ treeLoadView
{ root, mCurrentRoute, session, frontends, openNodes, reload, asyncTasks}
cpt { root
, mCurrentRoute
, session
, frontends
, openNodes
, reload
, asyncTasks
} _children = pure
$ treeLoadView { root
, mCurrentRoute
, session
, frontends
, openNodes
, reload
, asyncTasks
}
treeLoadView :: Record Props -> R.Element
treeLoadView p = R.createElement treeLoadViewCpt p []
......@@ -63,10 +75,16 @@ treeLoadView p = R.createElement treeLoadViewCpt p []
treeLoadViewCpt :: R.Component Props
treeLoadViewCpt = R.hooksComponent "TreeLoadView" cpt
where
cpt { root, asyncTasks, mCurrentRoute, session, frontends, openNodes, reload } _children = do
let fetch _ = loadNode session root
let paint loaded = loadedTreeView {
asyncTasks
cpt { root
, asyncTasks
, mCurrentRoute
, session
, frontends
, openNodes
, reload
} _children = do
let fetch _ = getNodeTree session root
let paint loaded = loadedTreeView { asyncTasks
, frontends
, mCurrentRoute
, openNodes
......@@ -77,9 +95,9 @@ treeLoadView p = R.createElement treeLoadViewCpt p []
}
useLoader { root, counter: fst reload } fetch paint
type TreeViewProps = ( asyncTasks :: R.State GAT.Storage
, tree :: FTree
, tasks :: Record Tasks
type TreeViewProps = ( asyncTasks :: R.State GAT.Storage
, tree :: FTree
, tasks :: Record Tasks
| CommonProps
)
......@@ -89,16 +107,31 @@ loadedTreeView p = R.createElement loadedTreeViewCpt p []
loadedTreeViewCpt :: R.Component TreeViewProps
loadedTreeViewCpt = R.hooksComponent "LoadedTreeView" cpt
where
cpt { asyncTasks, frontends, mCurrentRoute, openNodes, reload, tasks, tree, session } _ = do
pure $ H.div {className: "tree"}
[ toHtml { asyncTasks, frontends, mCurrentRoute, openNodes, reload, session, tasks, tree } ]
cpt { asyncTasks
, frontends
, mCurrentRoute
, openNodes
, reload
, tasks
, tree
, session
} _ = pure $ H.div { className: "tree"}
[ toHtml { asyncTasks
, frontends
, mCurrentRoute
, openNodes
, reload
, session
, tasks
, tree
}
]
------------------------------------------------------------------------
type ToHtmlProps =
(
asyncTasks :: R.State GAT.Storage
, tasks :: Record Tasks
, tree :: FTree
( asyncTasks :: R.State GAT.Storage
, tasks :: Record Tasks
, tree :: FTree
| CommonProps
)
......@@ -109,59 +142,72 @@ toHtml p@{ asyncTasks
, openNodes
, reload: reload@(_ /\ setReload)
, session
, tasks: tasks@{ onTaskAdd, onTaskFinish, tasks: tasks' }
, tree: tree@(NTree (LNode {id, name, nodeType}) ary) } = R.createElement el {} []
where
el = R.hooksComponent "NodeView" cpt
commonProps = RecordE.pick p :: Record CommonProps
pAction = performAction (RecordE.pick p :: Record PerformActionProps)
cpt _ _ = do
let nodeId = mkNodeId session id
let folderIsOpen = Set.member nodeId (fst openNodes)
let setFn = if folderIsOpen then Set.delete else Set.insert
let toggleFolderIsOpen _ = (snd openNodes) (setFn nodeId)
let folderOpen = Tuple folderIsOpen toggleFolderIsOpen
let withId (NTree (LNode {id: id'}) _) = id'
pure $ H.ul {}
[ H.li {}
( [ nodeMainSpan { id
, dispatch: pAction
, folderOpen
, frontends
, mCurrentRoute
, name
, nodeType
, session
, tasks
} ]
<> childNodes (Record.merge commonProps
{ asyncTasks
, children: ary
, folderOpen })
)
]
, tasks: tasks@{ onTaskAdd
, onTaskFinish
, tasks: tasks'
}
, tree: tree@(NTree (LNode { id
, name
, nodeType
}
) ary
)
} =
R.createElement el {} []
where
el = R.hooksComponent "NodeView" cpt
commonProps = RecordE.pick p :: Record CommonProps
pAction a = performAction a (RecordE.pick p :: Record PerformActionProps)
cpt _ _ = do
let nodeId = mkNodeId session id
let folderIsOpen = Set.member nodeId (fst openNodes)
let setFn = if folderIsOpen then Set.delete else Set.insert
let toggleFolderIsOpen _ = (snd openNodes) (setFn nodeId)
let folderOpen = Tuple folderIsOpen toggleFolderIsOpen
let withId (NTree (LNode {id: id'}) _) = id'
pure $ H.ul {}
[ H.li {}
( [ nodeMainSpan { id
, dispatch: pAction
, folderOpen
, frontends
, mCurrentRoute
, name
, nodeType
, session
, tasks
} ]
<> childNodes (Record.merge commonProps
{ asyncTasks
, children: ary
, folderOpen
}
)
)
]
type ChildNodesProps =
( asyncTasks :: R.State GAT.Storage
, children :: Array FTree
, children :: Array FTree
, folderOpen :: R.State Boolean
| CommonProps
)
childNodes :: Record ChildNodesProps -> Array R.Element
childNodes { children: [] } = []
childNodes { folderOpen: (false /\ _) } = []
childNodes { children: [] } = []
childNodes { folderOpen: (false /\ _) } = []
childNodes props@{ asyncTasks, children, reload } =
map (\ctree@(NTree (LNode {id}) _) ->
toHtml (Record.merge commonProps {
asyncTasks
, tasks: tasksStruct id asyncTasks reload
, tree: ctree
})) $ sorted children
toHtml (Record.merge commonProps { asyncTasks
, tasks: tasksStruct id asyncTasks reload
, tree: ctree
}
)
) $ sorted children
where
commonProps = RecordE.pick props :: Record CommonProps
sorted :: Array FTree -> Array FTree
......@@ -175,54 +221,85 @@ type PerformActionProps =
, tree :: FTree
)
performAction :: Record PerformActionProps
-> Action
-------
performAction :: Action
-> Record PerformActionProps
-> Aff Unit
performAction p@{ openNodes: (_ /\ setOpenNodes)
, reload: (_ /\ setReload)
, session
, tree: (NTree (LNode {id}) _) } DeleteNode = do
void $ deleteNode session id
liftEffect do
setOpenNodes (Set.delete (mkNodeId session id))
performAction p RefreshTree
performAction { reload: (_ /\ setReload)
, session
, tasks: { onTaskAdd }
, tree: (NTree (LNode {id}) _) } (SearchQuery task) = do
liftEffect $ onTaskAdd task
liftEffect $ log2 "[performAction] SearchQuery task:" task
performAction { reload: (_ /\ setReload)
, session
, tasks: {onTaskAdd}
, tree: (NTree (LNode {id}) _) } (UpdateNode task) = do
liftEffect $ onTaskAdd task
liftEffect $ log2 "[performAction] UpdateNode task:" task
performAction p@{ reload: (_ /\ setReload)
, session
, tree: (NTree (LNode {id}) _) } (Submit name) = do
void $ renameNode session id $ RenameValue {name}
performAction p RefreshTree
performAction p@{ openNodes: (_ /\ setOpenNodes)
, reload: (_ /\ setReload)
, session
, tree: (NTree (LNode {id}) _) } (CreateSubmit name nodeType) = do
task <- addNode session id $ AddNodeValue {name, nodeType}
liftEffect do
setOpenNodes (Set.insert (mkNodeId session id))
performAction p RefreshTree
performAction { session
, tasks: { onTaskAdd }
, tree: (NTree (LNode {id}) _) } (UploadFile nodeType fileType mName contents) = do
task <- uploadFile session nodeType id fileType {mName, contents}
liftEffect $ onTaskAdd task
liftEffect $ log2 "uploaded, task:" task
performAction { reload: (_ /\ setReload) } RefreshTree = do
performAction DeleteNode p@{ openNodes: (_ /\ setOpenNodes)
, reload: (_ /\ setReload)
, session
, tree: (NTree (LNode {id}) _)
} =
do
void $ deleteNode session id
liftEffect $ setOpenNodes (Set.delete (mkNodeId session id))
performAction RefreshTree p
-------
performAction (DoSearch task) { reload: (_ /\ setReload)
, session
, tasks: { onTaskAdd }
, tree: (NTree (LNode {id}) _)
} =
do
liftEffect $ onTaskAdd task
liftEffect $ log2 "[performAction] DoSearch task:" task
-------
performAction (UpdateNode params) { reload: (_ /\ setReload)
, session
, tasks: {onTaskAdd}
, tree: (NTree (LNode {id}) _)
} =
do
task <- updateRequest params session id
liftEffect $ onTaskAdd task
liftEffect $ log2 "[performAction] UpdateNode task:" task
-------
performAction (RenameNode name) p@{ reload: (_ /\ setReload)
, session
, tree: (NTree (LNode {id}) _)
} =
do
void $ rename session id $ RenameValue {text:name}
performAction RefreshTree p
-------
performAction (ShareNode username) p@{ reload: (_ /\ setReload)
, session
, tree: (NTree (LNode {id}) _)
} =
do
void $ share session id $ ShareValue {text:username}
-------
performAction (AddNode name nodeType) p@{ openNodes: (_ /\ setOpenNodes)
, reload: (_ /\ setReload)
, session
, tree: (NTree (LNode {id}) _)
} =
do
task <- addNode session id $ AddNodeValue {name, nodeType}
liftEffect $ setOpenNodes (Set.insert (mkNodeId session id))
performAction RefreshTree p
-------
performAction (UploadFile nodeType fileType mName contents) { session
, tasks: { onTaskAdd }
, tree: (NTree (LNode {id}) _)
} =
do
task <- uploadFile session nodeType id fileType {mName, contents}
liftEffect $ onTaskAdd task
liftEffect $ log2 "Uploaded, task:" task
-------
performAction DownloadNode _ = do
liftEffect $ log "[performAction] DownloadNode"
-------
performAction RefreshTree { reload: (_ /\ setReload) } = do
liftEffect $ setReload (_ + 1)
-------
src/Gargantext/Components/Forest/Tree/Node.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node where
import Prelude (class Eq, class Show, show, (&&), (<>), (==))
import Data.Array (foldl)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Gargantext.Types
import Data.Nullable (null)
import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff, launchAff)
import Effect.Class (liftEffect)
import Gargantext.Components.Forest.Tree.Node.Settings (SettingsBox(..), settingsBox)
import Gargantext.Components.Forest.Tree.Node.Action (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Upload.Types (FileType(..), UploadFileContents(..))
import Gargantext.Components.Forest.Tree.Node.Action.Upload (DroppedFile(..), fileTypeView)
import Gargantext.Components.Forest.Tree.Node.Box (nodePopupView)
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.GraphExplorer.API as GraphAPI
import Gargantext.Components.Lang (Lang(EN))
import Gargantext.Components.Nodes.Corpus (loadCorpusWithChild)
import Gargantext.Ends (Frontends, url)
import Gargantext.Hooks.Loader (useLoader)
import Gargantext.Prelude (Unit, bind, const, discard, map, pure, show, unit, void, ($), (<>), (==))
import Gargantext.Routes as Routes
import Gargantext.Sessions (Session, sessionId)
import Gargantext.Types (Name, ID)
import Gargantext.Types as GT
import Gargantext.Utils.Popover as Popover
import Gargantext.Utils.Reactix as R2
import React.SyntheticEvent as E
import Reactix as R
import Reactix.DOM.HTML as H
import Web.File.FileReader.Aff (readAsText)
-- Main Node
type NodeMainSpanProps =
( id :: ID
, folderOpen :: R.State Boolean
, frontends :: Frontends
, mCurrentRoute :: Maybe Routes.AppRoute
, name :: Name
, nodeType :: GT.NodeType
, tasks :: Record Tasks
| CommonProps
)
nodeMainSpan :: Record NodeMainSpanProps
-> R.Element
nodeMainSpan p@{ dispatch, folderOpen, frontends, session } = R.createElement el p []
where
el = R.hooksComponent "G.C.F.T.N.B.NodeMainSpan" cpt
cpt props@{id, mCurrentRoute, name, nodeType, tasks: { onTaskFinish, tasks }} _ = do
-- only 1 popup at a time is allowed to be opened
droppedFile <- R.useState' (Nothing :: Maybe DroppedFile)
isDragOver <- R.useState' false
popoverRef <- R.useRef null
pure $ H.span (dropProps droppedFile isDragOver) $
[ folderIcon nodeType folderOpen
, if showBox then
Popover.popover { arrow: false
, open: false
, onClose: \_ -> pure unit
, onOpen: \_ -> pure unit
, ref: popoverRef } [
popOverIcon
, mNodePopupView props (onPopoverClose popoverRef)
]
else H.div {} []
, H.a { href: (url frontends (GT.NodePath (sessionId session) nodeType (Just id)))
}
[ nodeText { isSelected: mAppRouteId mCurrentRoute == Just id
, name: name' props
} ]
, nodeActions { id
, nodeType
, refreshTree: const $ dispatch RefreshTree
, session }
, fileTypeView {dispatch, droppedFile, id, isDragOver, nodeType}
, H.div {} (map (\t -> asyncProgressBar { asyncTask: t
, barType: Pie
, corpusId: id
, onFinish: const $ onTaskFinish t
, session
}
) tasks
)
]
where
SettingsBox {show: showBox} = settingsBox nodeType
onPopoverClose popoverRef _ = Popover.setOpen popoverRef false
name' {name, nodeType} = if nodeType == GT.NodeUser
then show session
else name
folderIcon nodeType folderOpen'@(open /\ _) =
H.a { className: "folder-icon"
, onClick: R2.effToggler folderOpen'
}
[ H.i {className: GT.fldr nodeType open} [] ]
popOverIcon = H.a { className: "settings fa fa-cog" } []
mNodePopupView props@{id, nodeType} onPopoverClose =
nodePopupView { id
, dispatch
, name: name' props
, nodeType
, onPopoverClose
, session
}
dropProps droppedFile isDragOver =
{ className: "leaf " <> (dropClass droppedFile isDragOver)
, on: { drop: dropHandler droppedFile
, dragOver: onDragOverHandler isDragOver
, dragLeave: onDragLeave isDragOver } }
where
dropClass (Just _ /\ _) _ = "file-dropped"
dropClass _ (true /\ _) = "file-dropped"
dropClass (Nothing /\ _) _ = ""
dropHandler (_ /\ setDroppedFile) e = do
-- prevent redirection when file is dropped
E.preventDefault e
E.stopPropagation e
blob <- R2.dataTransferFileBlob e
void $ launchAff do
contents <- readAsText blob
liftEffect $ setDroppedFile
$ const
$ Just
$ DroppedFile { contents: (UploadFileContents contents)
, fileType: Just CSV
, lang : EN
}
onDragOverHandler (_ /\ setIsDragOver) e = do
-- prevent redirection when file is dropped
-- https://stackoverflow.com/a/6756680/941471
E.preventDefault e
E.stopPropagation e
setIsDragOver $ const true
onDragLeave (_ /\ setIsDragOver) _ = setIsDragOver $ const false
------------------------------------------------------------------------
------------------------------------------------------------------------
{-
-- | TODO
filterWithRights (show action if user can only)
fldr nt open = if open
then "fa fa-globe" -- <> color nt
else "fa fa-folder-globe" -- <> color nt
--else "glyphicon glyphicon-folder-close" <> color nt
where
color GT.NodeUser = ""
color FolderPublic = ""
color FolderShared = " text-warning"
color _ = " text-danger"
-}
------------------------------------------------------------------------
------------------------------------------------------------------------
data Status a = IsBeta a | IsProd a
data NodeAction = Documentation NodeType
| SearchBox
| Download | Upload | Refresh | Config
| Move | Clone | Delete
| Share | Link NodeType
| Add (Array NodeType)
| CopyFromCorpus
instance eqNodeAction :: Eq NodeAction where
eq (Documentation x) (Documentation y) = true && (x == y)
eq SearchBox SearchBox = true
eq Download Download = true
eq Upload Upload = true
eq Refresh Refresh = true
eq Move Move = true
eq Clone Clone = true
eq Delete Delete = true
eq Share Share = true
eq (Link x) (Link y) = true && (x == y)
eq (Add x) (Add y) = true && (x == y)
eq CopyFromCorpus CopyFromCorpus = true
eq Config Config = true
eq _ _ = false
instance showNodeAction :: Show NodeAction where
show (Documentation x) = "Documentation of " <> show x
show SearchBox = "SearchBox"
show Download = "Download"
show Upload = "Upload"
show Refresh = "Refresh"
show Move = "Move"
show Clone = "Clone"
show Delete = "Delete"
show Share = "Share"
show Config = "Config"
show (Link x) = "Link to " <> show x
show (Add xs) = foldl (\a b -> a <> show b) "Add " xs
show CopyFromCorpus = "Copy from corpus"
glyphiconNodeAction :: NodeAction -> String
glyphiconNodeAction (Documentation _) = "question-sign"
glyphiconNodeAction Delete = "trash"
glyphiconNodeAction (Add _) = "plus"
glyphiconNodeAction SearchBox = "search"
glyphiconNodeAction Upload = "upload"
glyphiconNodeAction (Link _) = "transfer"
glyphiconNodeAction Download = "download"
glyphiconNodeAction CopyFromCorpus = "random"
glyphiconNodeAction Refresh = "refresh"
glyphiconNodeAction Config = "wrench"
glyphiconNodeAction _ = ""
------------------------------------------------------------------------
data SettingsBox =
SettingsBox { show :: Boolean
, edit :: Boolean
, doc :: NodeAction
, buttons :: Array NodeAction
}
------------------------------------------------------------------------
settingsBox :: NodeType -> SettingsBox
settingsBox NodeUser = SettingsBox {
show : true
, edit : false
, doc : Documentation NodeUser
, buttons : [ Delete ]
}
settingsBox FolderPrivate = SettingsBox {
show : true
, edit : false
, doc : Documentation FolderPrivate
, buttons : [ Add [ Corpus
, Folder
, Annuaire
]
]
}
settingsBox Team = SettingsBox {
show : true
, edit : true
, doc : Documentation Team
, buttons : [ Add [ Corpus
, Folder
, Annuaire
]
, Delete]
}
settingsBox FolderShared = SettingsBox {
show : true
, edit : true
, doc : Documentation FolderShared
, buttons : [ Add [Team, FolderShared]
-- , Delete
]
}
settingsBox FolderPublic = SettingsBox {
show : true
, edit : false
, doc : Documentation FolderPublic
, buttons : [ Add [ Corpus
, Folder
]
]
}
settingsBox Folder =
SettingsBox { show : true
, edit : true
, doc : Documentation Folder
, buttons : [ Add [ Corpus
, Folder
, Annuaire
]
, Delete
]
}
settingsBox Corpus =
SettingsBox { show : true
, edit : true
, doc : Documentation Corpus
, buttons : [ SearchBox
, Add [ NodeList
, Graph
, Dashboard
]
, Upload
, Download
--, Share
--, Move
--, Clone
, Link Annuaire
, Delete
]
}
settingsBox Texts =
SettingsBox { show : true
, edit : false
, doc : Documentation Texts
, buttons : [ Refresh
, Upload
, Download
-- , Delete
]
}
settingsBox Graph =
SettingsBox { show : true
, edit : false
, doc : Documentation Graph
, buttons : [ Refresh
, Config
, Download -- TODO as GEXF or JSON
, Delete
]
}
settingsBox NodeList =
SettingsBox { show : true
, edit : false
, doc : Documentation NodeList
, buttons : [ Refresh
, Config
, Download
, Upload
, CopyFromCorpus
, Delete
]
}
settingsBox Dashboard =
SettingsBox { show : true
, edit : false
, doc : Documentation Dashboard
, buttons : []
}
settingsBox Annuaire =
SettingsBox { show : true
, edit : false
, doc : Documentation Annuaire
, buttons : [ Upload
, Delete
]
}
-- 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 =
( id :: ID
, nodeType :: GT.NodeType
, refreshTree :: Unit -> Aff Unit
, session :: Session
)
nodeActions :: Record NodeActionsProps -> R.Element
nodeActions p = R.createElement nodeActionsCpt p []
nodeActionsCpt :: R.Component NodeActionsProps
nodeActionsCpt = R.hooksComponent "G.C.F.T.N.B.nodeActions" cpt
where
cpt { id
, nodeType: GT.Graph
, refreshTree
, session
} _ = do
useLoader id (graphVersions session) $ \gv ->
nodeActionsGraph { id
, graphVersions: gv
, session
, triggerRefresh: triggerRefresh refreshTree
}
cpt { id
, nodeType: GT.NodeList
, refreshTree
, session
} _ = do
useLoader { nodeId: id, session } loadCorpusWithChild $
\{ corpusId } ->
nodeActionsNodeList { listId: id
, nodeId: corpusId
, nodeType: GT.TabNgramType GT.CTabTerms
, session
, triggerRefresh: triggerRefresh refreshTree
}
cpt _ _ = do
pure $ H.div {} []
graphVersions session graphId = GraphAPI.graphVersions { graphId, session }
triggerRefresh refreshTree = refreshTree
-- END nodeActions
mAppRouteId :: Maybe Routes.AppRoute -> Maybe Int
mAppRouteId (Just (Routes.Folder _ id)) = Just id
mAppRouteId (Just (Routes.FolderPrivate _ id)) = Just id
mAppRouteId (Just (Routes.FolderPublic _ id)) = Just id
mAppRouteId (Just (Routes.FolderShared _ id)) = Just id
mAppRouteId (Just (Routes.Team _ id)) = Just id
mAppRouteId (Just (Routes.Corpus _ id)) = Just id
mAppRouteId (Just (Routes.PGraphExplorer _ id)) = Just id
mAppRouteId (Just (Routes.Dashboard _ id)) = Just id
mAppRouteId (Just (Routes.Texts _ id)) = Just id
mAppRouteId (Just (Routes.Lists _ id)) = Just id
mAppRouteId (Just (Routes.Annuaire _ id)) = Just id
mAppRouteId (Just (Routes.UserPage _ id)) = Just id
mAppRouteId (Just (Routes.Document _ id _ )) = Just id
mAppRouteId (Just (Routes.ContactPage _ id _ )) = Just id
mAppRouteId (Just (Routes.CorpusDocument _ id _ _)) = Just id
mAppRouteId _ = Nothing
settingsBox _ =
SettingsBox { show : false
, edit : false
, doc : Documentation NodeUser
, buttons : []
}
src/Gargantext/Components/Forest/Tree/Node/Action.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action where
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, jsonEmptyObject, (.:), (:=), (~>))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Data.Maybe (Maybe)
import Effect.Aff (Aff)
import Prelude hiding (div)
import Gargantext.Components.Lang (Lang)
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, get, put, post, delete)
import Gargantext.Routes as GR
import Gargantext.Prelude (class Show, Unit)
import Gargantext.Sessions (Session)
import Gargantext.Types as GT
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
)
-}
data Action = CreateSubmit String GT.NodeType
data Action = AddNode String GT.NodeType
| DeleteNode
| UpdateNode GT.AsyncTaskWithType
| SearchQuery GT.AsyncTaskWithType
| Submit String
| RenameNode String
| UpdateNode UpdateNodeParams
| ShareNode String
| DoSearch GT.AsyncTaskWithType
| UploadFile GT.NodeType FileType (Maybe String) UploadFileContents
| DownloadNode
| RefreshTree
-----------------------------------------------------
-- TODO Delete with asyncTaskWithType
deleteNode :: Session -> GT.ID -> Aff GT.ID
deleteNode session nodeId = delete session $ NodeAPI GT.Node (Just nodeId) ""
-----------------------------------------------------------------------
instance showShow :: Show Action where
show (AddNode _ _ )= "AddNode"
show DeleteNode = "DeleteNode"
show (RenameNode _ )= "RenameNode"
show (UpdateNode _ )= "UpdateNode"
show (ShareNode _ )= "ShareNode"
show (DoSearch _ )= "SearchQuery"
show (UploadFile _ _ _ _)= "UploadFile"
show RefreshTree = "RefreshTree"
show DownloadNode = "Download"
type Props =
( dispatch :: Action -> Aff Unit
......@@ -35,18 +48,27 @@ type Props =
, nodeType :: GT.NodeType
, session :: Session
)
-----------------------------------------------------------------------
icon :: Action -> String
icon (AddNode _ _) = glyphiconNodeAction (Add [])
icon DeleteNode = glyphiconNodeAction Delete
icon (RenameNode _) = glyphiconNodeAction Config
icon (UpdateNode _) = glyphiconNodeAction Refresh
icon (ShareNode _) = glyphiconNodeAction Share
icon (DoSearch _) = glyphiconNodeAction SearchBox
icon (UploadFile _ _ _ _) = glyphiconNodeAction Upload
icon RefreshTree = glyphiconNodeAction Refresh
icon DownloadNode = glyphiconNodeAction Download
-- icon _ = "hand-o-right"
-- TODO remove these types from here
data FileType = CSV | CSV_HAL | WOS | PresseRIS
derive instance genericFileType :: Generic FileType _
instance eqFileType :: Eq FileType where
eq = genericEq
instance showFileType :: Show FileType where
show = genericShow
newtype UploadFileContents = UploadFileContents String
text :: Action -> String
text (AddNode _ _ )= "Add !"
text DeleteNode = "Delete !"
text (RenameNode _ )= "Rename !"
text (UpdateNode _ )= "Update !"
text (ShareNode _ )= "Share !"
text (DoSearch _ )= "Launch search !"
text (UploadFile _ _ _ _)= "Upload File !"
text RefreshTree = "Refresh Tree !"
text DownloadNode = "Download !"
-----------------------------------------------------------------------
src/Gargantext/Components/Forest/Tree/Node/Action/Add.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Add where
import Data.Array (length, head)
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, jsonEmptyObject, (.:), (:=), (~>))
import Data.Argonaut (class EncodeJson, jsonEmptyObject, (:=), (~>))
import Data.Array (head)
import Data.Maybe (Maybe(..), fromMaybe)
-- import Data.Newtype (class Newtype)
import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff, launchAff)
import Effect.Uncurried (mkEffectFn1)
import Effect.Aff (Aff)
import Gargantext.Components.Forest.Tree.Node.Settings (SettingsBox(..), settingsBox)
import Gargantext.Components.Forest.Tree.Node.Action (Action(..))
import Gargantext.Components.Forest.Tree.Node (SettingsBox(..), settingsBox)
import Gargantext.Types (NodeType(..), readNodeType)
import Gargantext.Utils.Reactix as R2
import Gargantext.Sessions (Session, post)
import Gargantext.Components.Forest.Tree.Node.Tools (submitButton, formEdit, formChoiceSafe, panel)
import Gargantext.Prelude (Unit, bind, pure, show, ($), (<>))
import Gargantext.Routes as GR
import Gargantext.Sessions (Session, post)
import Gargantext.Types as GT
import Prelude (Unit, bind, const, discard, map, pure, show, ($), (<>), (>), (<<<))
import Gargantext.Types (NodeType(..))
import Reactix as R
import Reactix.DOM.HTML as H
......@@ -23,9 +21,9 @@ addNode :: Session -> GT.ID -> AddNodeValue -> Aff (Array GT.ID)
addNode session parentId = post session $ GR.NodeAPI GT.Node (Just parentId) ""
addNodeAsync :: Session
-> GT.ID
-> AddNodeValue
-> Aff GT.AsyncTaskWithType
-> GT.ID
-> AddNodeValue
-> Aff GT.AsyncTaskWithType
addNodeAsync session parentId q = do
task <- post session p q
pure $ GT.AsyncTaskWithType {task, typ: GT.AddNode}
......@@ -57,77 +55,23 @@ type CreateNodeProps =
)
addNodeView :: Record CreateNodeProps
-> R.Element
-> R.Element
addNodeView p@{ dispatch, nodeType, nodeTypes } = R.createElement el p []
where
el = R.hooksComponent "AddNodeView" cpt
cpt {id, name} _ = do
nodeName <- R.useState' "Name"
nodeType' <- R.useState' $ fromMaybe NodeUser $ head nodeTypes
pure $ H.div {}
[ panelBody readNodeType nodeName nodeType'
, panelFooter nodeName nodeType'
]
where
panelBody :: (String -> NodeType)
-> R.State String
-> R.State NodeType
-> R.Element
panelBody readIt (_ /\ setNodeName) (nt /\ setNodeType) =
H.div {className: "panel-body"}
[ H.div {className: "row"}
[ H.div {className: "col-md-10"}
[ H.form {className: "form-horizontal"} $ maybeChoose <> maybeEdit ]
]
]
where
SettingsBox {edit} = settingsBox nt
maybeEdit = [ if edit then
H.div {className: "form-group"}
[ H.input { type: "text"
, placeholder: "Node name"
, defaultValue: "Write Name here"
, className: "form-control"
, onInput: mkEffectFn1 $ setNodeName <<< const <<< R2.unsafeEventValue
}
]
else
H.div {} []
]
maybeChoose = [ if length nodeTypes > 1 then
R.fragment [
H.div {className: "form-group"} $ [
R2.select { className: "form-control"
, onChange: mkEffectFn1 $ setNodeType <<< const <<< readIt <<< R2.unsafeEventValue
}
(map (\opt -> H.option {} [ H.text $ show opt ]) nodeTypes)
]
-- , showConfig nt
]
else
H.button { className : "btn btn-primary"
, type : "button"
, onClick : mkEffectFn1 $ \_ -> setNodeType ( const
$ fromMaybe nt
$ head nodeTypes
)
} []
]
nodeName@(name' /\ setNodeName) <- R.useState' "Name"
nodeType'@(nt /\ setNodeType) <- R.useState' $ fromMaybe NodeUser $ head nodeTypes
let
SettingsBox {edit} = settingsBox nt
maybeChoose = [ formChoiceSafe nodeTypes Error setNodeType ]
maybeEdit = [ if edit
then formEdit "Node Name" setNodeName
else H.div {} []
]
panelFooter :: R.State String -> R.State NodeType -> R.Element
panelFooter (name' /\ _) (nt /\ _) =
H.div {className: "panel-footer"}
[ H.button {className: "btn btn-primary text-center"
, type: "button"
, onClick: mkEffectFn1 $ \_ -> do
-- TODO
--setPopupOpen $ const Nothing
launchAff $ dispatch $ CreateSubmit name' nt
} [H.text "Add"]
]
pure $ panel (maybeChoose <> maybeEdit) (submitButton (AddNode name' nt) dispatch)
-- END Create Node
......
src/Gargantext/Components/Forest/Tree/Node/Action/CopyFrom.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.CopyFrom where
import Data.Array as A
import Data.Maybe (Maybe(..), fromJust)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import DOM.Simple.Console (log2)
import Effect.Aff (Aff, launchAff)
import Effect.Class (liftEffect)
import Effect (Effect)
import Partial.Unsafe (unsafePartial)
import React.SyntheticEvent as E
import Reactix as R
import Reactix.DOM.HTML as H
import URI.Extra.QueryPairs as QP
import Web.File.FileReader.Aff (readAsText)
import Gargantext.Prelude (class Show, Unit, bind, const, discard, map, pure, show, unit, void, ($), (&&), (/=), (<>))
import Gargantext.Components.Lang (readLang, Lang(..))
import Gargantext.Components.Forest.Tree.Node.Action (Action(..), Props)
import Gargantext.Components.Forest.Tree.Node.FTree (FTree, ID, LNode(..), NTree(..))
import Data.Array as A
import Data.Maybe (Maybe(..))
import Effect.Aff (Aff)
import Gargantext.Components.Forest.Tree.Node.Action (Props)
import Gargantext.Components.Forest.Tree.Node.Tools.FTree (FTree, LNode(..), NTree(..))
import Gargantext.Hooks.Loader (useLoader)
import Gargantext.Prelude (discard, map, pure, show, unit, ($), (&&), (/=), (<>))
import Gargantext.Routes as GR
import Gargantext.Sessions (Session(..), postWwwUrlencoded, get)
import Gargantext.Sessions (Session(..), get)
import Gargantext.Types as GT
import Gargantext.Utils (id)
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Reactix.DOM.HTML as H
loadNode :: Session -> GT.ID -> Aff FTree
loadNode session nodeId = get session $ GR.NodeAPI GT.Tree (Just nodeId) ""
------------------------------------------------------------------------
getNodeTree :: Session -> GT.ID -> Aff FTree
getNodeTree session nodeId = get session $ GR.NodeAPI GT.Tree (Just nodeId) ""
copyFromCorpusView :: Record Props -> R.Element
copyFromCorpusView props = R.createElement copyFromCorpusViewCpt props []
......@@ -38,10 +25,22 @@ copyFromCorpusView props = R.createElement copyFromCorpusViewCpt props []
copyFromCorpusViewCpt :: R.Component Props
copyFromCorpusViewCpt = R.hooksComponent "G.C.F.T.N.A.U.copyFromCorpusView" cpt
where
cpt {dispatch, id, nodeType, session} _ = do
useLoader session loadCorporaTree $
\tree ->
copyFromCorpusViewLoaded {dispatch, id, nodeType, session, tree}
cpt { dispatch
, id
, nodeType
, session
} _ =
do
useLoader session loadCorporaTree $
\tree ->
copyFromCorpusViewLoaded { dispatch
, id
, nodeType
, session
, tree
}
------------------------------------------------------------------------
type CorpusTreeProps =
( tree :: FTree
......@@ -55,9 +54,10 @@ copyFromCorpusViewLoadedCpt :: R.Component CorpusTreeProps
copyFromCorpusViewLoadedCpt = R.hooksComponent "G.C.F.T.N.A.U.copyFromCorpusViewLoadedCpt" cpt
where
cpt p@{dispatch, id, nodeType, session, tree} _ = do
pure $ H.div { className: "copy-from-corpus" } [
H.div { className: "tree" } [copyFromCorpusTreeView p]
]
pure $ H.div { className: "copy-from-corpus" }
[ H.div { className: "tree" }
[copyFromCorpusTreeView p]
]
copyFromCorpusTreeView :: Record CorpusTreeProps -> R.Element
copyFromCorpusTreeView props = R.createElement copyFromCorpusTreeViewCpt props []
......@@ -67,11 +67,13 @@ copyFromCorpusTreeViewCpt = R.hooksComponent "G.C.F.T.N.A.U.copyFromCorpusTreeVi
where
cpt p@{id, tree: NTree (LNode { id: sourceId, name, nodeType }) ary} _ = 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 ]
, -} H.div { className: "node" }
( [ H.span { className: "name " <> clickable
, on: { click: onClick }
} [ H.text name ]
] <> children)
] <> children
)
-- ]
where
children = map (\c -> copyFromCorpusTreeView (p { tree = c })) ary
......@@ -91,10 +93,12 @@ loadCorporaTree session = getCorporaTree session treeId
getCorporaTree :: Session -> Int -> Aff FTree
getCorporaTree session treeId = get session $ GR.NodeAPI GT.Tree (Just treeId) nodeTypes
where
nodeTypes = A.foldl (\a b -> a <> "type=" <> show b <> "&") "?" [ GT.FolderPrivate
, GT.FolderShared
, GT.Team
, GT.FolderPublic
, GT.Folder
, GT.Corpus
, GT.NodeList]
nodeTypes = A.foldl (\a b -> a <> "type=" <> show b <> "&") "?" typesList
typesList = [ GT.FolderPrivate
, GT.FolderShared
, GT.Team
, GT.FolderPublic
, GT.Folder
, GT.Corpus
, GT.NodeList
]
src/Gargantext/Components/Forest/Tree/Node/Action/Delete.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Delete
where
import Data.Maybe (Maybe(..))
import Gargantext.Prelude
import Effect.Aff (Aff)
import Gargantext.Types as GT
import Gargantext.Sessions (Session, delete)
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Types (NodeType(..))
import Gargantext.Components.Forest.Tree.Node.Action (Action(..))
import Reactix as R
import Gargantext.Components.Forest.Tree.Node.Tools (submitButton, panel)
import Reactix.DOM.HTML as H
-- TODO Delete with asyncTaskWithType
deleteNode :: Session -> GT.ID -> Aff GT.ID
deleteNode session nodeId = delete session $ NodeAPI GT.Node (Just nodeId) ""
-- | Action : Delete
actionDelete :: NodeType -> (Action -> Aff Unit) -> R.Hooks R.Element
actionDelete NodeUser _ = do
pure $ panel [ H.div { style: {margin: "10px"}}
[ H.text $ "Yes, we are RGPD compliant!"
<> " But you can not delete User Node yet."
<> " We are still on development."
<> " Thanks for your comprehensin."
]
]
(H.div {} [])
actionDelete _ dispatch = do
pure $ panel [ H.div {style: {margin: "10px"}}
(map (\t -> H.p {} [H.text t])
[ "Are your sure you want to delete it ?"
, "If yes, click again below."
]
)
]
(submitButton DeleteNode dispatch)
src/Gargantext/Components/Forest/Tree/Node/Action/Documentation.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Documentation where
import Gargantext.Prelude (map, pure, show, ($), (<>))
import Gargantext.Types (NodeType)
import Gargantext.Types as GT
import Reactix as R
import Reactix.DOM.HTML as H
import Gargantext.Components.Forest.Tree.Node.Tools (panel)
-- | Action: Show Documentation
actionDoc :: NodeType -> R.Hooks R.Element
actionDoc nodeType =
pure $ panel ( [ infoTitle nodeType ]
<> (map (\info -> H.p {} [H.text info]) $ docOf nodeType)
)
( H.div {} [])
where
infoTitle :: NodeType -> R.Element
infoTitle nt = H.div { style: {margin: "10px"}}
[ H.h3 {} [H.text "Documentation about " ]
, H.h3 {className: GT.fldr nt true} [ H.text $ show nt ]
]
-- | TODO add documentation of all NodeType
docOf :: NodeType -> Array String
docOf GT.NodeUser = [ "This account is personal"
, "See the instances terms of uses."
]
docOf GT.FolderPrivate = ["This folder and its children are private only."]
docOf GT.FolderPublic = ["Soon, you will be able to build public folders to share your work with the world!"]
docOf GT.FolderShared = ["Soon, you will be able to build teams folders to share your work"]
docOf nodeType = ["More information on " <> show nodeType]
src/Gargantext/Components/Forest/Tree/Node/Action/Download.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Download where
import Data.Maybe (Maybe(..))
import Gargantext.Components.Forest.Tree.Node.Action (Action(DownloadNode))
import Gargantext.Components.Forest.Tree.Node.Tools (fragmentPT, panel, submitButtonHref)
import Gargantext.Ends (url)
import Gargantext.Prelude (pure, ($))
import Gargantext.Routes as Routes
import Gargantext.Sessions (Session)
import Gargantext.Types (NodeType(..), ID)
import Gargantext.Types as GT
import Reactix as R
import Reactix.DOM.HTML as H
-- | Action : Download
actionDownload :: NodeType -> ID -> Session -> R.Hooks R.Element
actionDownload NodeList id session = pure $ panel [H.div {} [H.text info]]
(submitButtonHref DownloadNode href)
where
href = url session $ Routes.NodeAPI GT.NodeList (Just id) ""
info = "Info about the List as JSON format"
actionDownload GT.Graph id session = pure $ panel [H.div {} [H.text info]]
(submitButtonHref DownloadNode href)
where
href = url session $ Routes.NodeAPI GT.Graph (Just id) "gexf"
info = "Info about the Graph as GEXF format"
actionDownload GT.Corpus id session = pure $ panel [H.div {} [H.text info]]
(submitButtonHref DownloadNode href)
where
href = url session $ Routes.NodeAPI GT.Corpus (Just id) "export"
info = "Download as JSON"
{-
-- TODO fix the route
actionDownload GT.Texts id session = pure $ panel [H.div {} [H.text info]]
(submitButtonHref DownloadNode href)
where
href = url session $ Routes.NodeAPI GT.Texts (Just id) ""
info = "TODO: fix the backend route. What is the expected result ?"
-}
actionDownload _ _ _ = pure $ fragmentPT $ "Soon, you will be able to download your file here "
src/Gargantext/Components/Forest/Tree/Node/Action/Rename.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Rename where
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, jsonEmptyObject, (.:), (:=), (~>))
import Data.Argonaut (class EncodeJson, jsonEmptyObject, (:=), (~>))
import Data.Maybe (Maybe(..))
import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff, launchAff)
import Effect.Uncurried (mkEffectFn1)
import Prelude (Unit, bind, const, discard, pure, ($), (<<<))
import Reactix as R
import Reactix.DOM.HTML as H
import Effect.Aff (Aff)
import Prelude (($))
import Gargantext.Components.Forest.Tree.Node.Action
import Gargantext.Types as GT
import Gargantext.Types (NodeType, ID, Name)
import Gargantext.Types (ID)
import Gargantext.Routes as GR
import Gargantext.Utils.Reactix as R2
import Gargantext.Sessions (Session, get, put, post, delete)
import Gargantext.Sessions (Session, put)
renameNode :: Session -> ID -> RenameValue -> Aff (Array ID)
renameNode session renameNodeId =
------------------------------------------------------------------------
rename :: Session -> ID -> RenameValue -> Aff (Array ID)
rename session renameNodeId =
put session $ GR.NodeAPI GT.Node (Just renameNodeId) "rename"
renameAction :: String -> Action
renameAction newName = RenameNode newName
------------------------------------------------------------------------
newtype RenameValue = RenameValue
{ name :: Name }
{ text :: String }
instance encodeJsonRenameValue :: EncodeJson RenameValue where
encodeJson (RenameValue {name})
= "r_name" := name
encodeJson (RenameValue {text})
= "r_name" := text
~> jsonEmptyObject
-- | START Rename Box
type RenameBoxProps =
( id :: ID
, dispatch :: Action -> Aff Unit
, name :: Name
, nodeType :: NodeType
, renameBoxOpen :: R.State Boolean
)
renameBox :: Record RenameBoxProps -> R.Element
renameBox p@{ dispatch, renameBoxOpen: (true /\ setRenameBoxOpen) } = R.createElement el p []
where
el = R.hooksComponent "RenameBox" cpt
cpt {id, name, nodeType} _ = do
renameNodeName <- R.useState' name
pure $ H.div {className: "from-group row-no-padding"}
[ renameInput renameNodeName
, renameBtn renameNodeName
, cancelBtn
]
where
renameInput (_ /\ setRenameNodeName) =
H.div {className: "col-md-8"}
[ H.input { type: "text"
, placeholder: "Rename Node"
, defaultValue: name
, className: "form-control"
, onInput: mkEffectFn1 $ setRenameNodeName <<< const <<< R2.unsafeEventValue
}
]
renameBtn (newName /\ _) =
H.a {className: "btn glyphitem glyphicon glyphicon-ok col-md-2 pull-left"
, type: "button"
, onClick: mkEffectFn1 $ \_ -> do
setRenameBoxOpen $ const false
launchAff $ dispatch $ Submit newName
, title: "Rename"
} []
cancelBtn =
H.a {className: "btn text-danger glyphitem glyphicon glyphicon-remove col-md-2 pull-left"
, type: "button"
, onClick: mkEffectFn1 $ \_ -> setRenameBoxOpen $ const false
, title: "Cancel"
} []
renameBox p@{ renameBoxOpen: (false /\ _) } = R.createElement el p []
where
el = R.hooksComponent "RenameBox" cpt
cpt {name} _ = pure $ H.div {} []
-- END Rename Box
------------------------------------------------------------------------
src/Gargantext/Components/Forest/Tree/Node/Action/Search.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Search where
import Data.Maybe (Maybe)
import Effect (Effect)
import Effect.Aff (Aff, launchAff)
import Gargantext.Components.Forest.Tree.Node.Action (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Add (NodePopup)
import Gargantext.Components.Forest.Tree.Node.Action.Search.SearchBar (searchBar)
import Gargantext.Components.Forest.Tree.Node.Action.Search.SearchField (defaultSearch)
import Gargantext.Components.Lang (allLangs)
import Gargantext.Prelude (Unit, bind, pure, unit, ($), (<>))
import Gargantext.Sessions (Session)
import Gargantext.Types (ID)
import Gargantext.Types as GT
import Reactix as R
import Reactix.DOM.HTML as H
-- | Action : Search
actionSearch :: Session
-> Maybe ID
-> (Action -> Aff Unit)
-> Maybe NodePopup
-> R.Hooks R.Element
actionSearch session id dispatch nodePopup = do
search <- R.useState' $ defaultSearch { node_id = id }
pure $ R.fragment [ H.p {"style": {"margin" :"10px"}}
[ H.text $ "Search and create a private "
<> "corpus with the search query as corpus name." ]
, searchBar { langs: allLangs
, onSearch: searchOn dispatch nodePopup
, search
, session
}
]
where
searchOn :: (Action -> Aff Unit)
-> Maybe NodePopup
-> GT.AsyncTaskWithType
-> Effect Unit
searchOn dispatch' p task = do
_ <- launchAff $ dispatch' (DoSearch task)
-- close popup
-- TODO
--snd p $ const Nothing
pure unit
src/Gargantext/Components/Forest/Tree/Node/Action/Search/Frame.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Search.Frame where
import DOM.Simple as DOM
import DOM.Simple.Event (MessageEvent)
import DOM.Simple.EventListener (Callback, addEventListener, callback)
import DOM.Simple.Window (window)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable)
import Data.String (toLower)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Gargantext.Components.Forest.Tree.Node.Action.Search.Types (DataField(..), Search, isIsTex_Advanced)
import Gargantext.Prelude (discard, identity, pure, unit, ($), (<>), (==), class Show, show)
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Reactix.DOM.HTML as H
import URI.Extra.QueryPairs as NQP
import URI.Query as Query
--------------------
data FrameSource = Istex | Searx
derive instance genericFrameSource :: Generic FrameSource _
instance showFrameSource :: Show FrameSource where
show = genericShow
--------------------
-- | Iframes
searchIframes :: R.State Search
-> R.Ref (Nullable DOM.Element)
-> R.Element
searchIframes search@(search' /\ _) iframeRef =
if isIsTex_Advanced search'.datafield
then divIframe Istex search iframeRef
else
if Just Web == search'.datafield
then divIframe Searx search iframeRef
else H.div {} []
divIframe :: FrameSource
-> R.State Search
-> R.Ref (Nullable DOM.Element)
-> R.Element
divIframe frameSource search@(search' /\ _) iframeRef =
H.div { className: "frame-search panel panel-default" }
[ iframeWith (frameUrl frameSource)search iframeRef ]
frameUrl :: FrameSource -> String
frameUrl frameSource = frameUrl' (toLower $ show frameSource)
where
frameUrl' s = "https://" <> s <> ".frame.gargantext.org"
iframeWith :: String
-> R.State Search
-> R.Ref (Nullable DOM.Element)
-> R.Element
iframeWith url (search /\ setSearch) iframeRef =
H.iframe { src: isTexTermUrl search.term
, width: "100%"
, height: "100%"
, ref: iframeRef
, on: { load: \_ -> do
addEventListener window "message" (changeSearchOnMessage url)
R2.postMessage iframeRef search.term
}
} []
where
changeSearchOnMessage :: String -> Callback MessageEvent
changeSearchOnMessage url' =
callback $ \m -> if R2.getMessageOrigin m == url'
then do
let {url'', term} = R2.getMessageData m
setSearch $ _ {url = url'', term = term}
else
pure unit
isTexTermUrl term = url <> query
where
query = Query.print $ NQP.print identity identity qp
qp = NQP.QueryPairs [ Tuple (NQP.keyFromString "query")
(Just (NQP.valueFromString term))
]
src/Gargantext/Components/Search/SearchBar.purs → src/Gargantext/Components/Forest/Tree/Node/Action/Search/SearchBar.purs
View file @ 0b03d8c1
module Gargantext.Components.Search.SearchBar
module Gargantext.Components.Forest.Tree.Node.Action.Search.SearchBar
( Props, searchBar, searchBarCpt
) where
import Data.Tuple.Nested ((/\))
import Data.Nullable (Nullable)
import Reactix as R
import Reactix.DOM.HTML as H
import Gargantext.Components.Search.Types -- (Database, SearchQuery(..), defaultSearchQuery, performSearch, Lang(..))
import Effect (Effect)
import Gargantext.Components.Forest.Tree.Node.Action.Search.SearchField (searchField)
import Gargantext.Components.Forest.Tree.Node.Action.Search.Types -- (Database, SearchQuery(..), defaultSearchQuery, performSearch, Lang(..))
import Gargantext.Components.Lang (Lang)
import Gargantext.Components.Search.SearchField (Search, searchField)
import Gargantext.Components.Search.Types (allDatabases) -- (Database, SearchQuery(..), defaultSearchQuery, performSearch, Lang(..))
import Gargantext.Prelude (Unit, pure, ($))
import Gargantext.Sessions (Session)
import Gargantext.Types as GT
......@@ -33,10 +28,10 @@ searchBarCpt = R.hooksComponent "G.C.Node.SearchBar.searchBar" cpt
cpt {langs, onSearch, search: search@(s /\ _), session} _ = do
--onSearchChange session s
pure $ H.div {"style": {"margin" :"10px"}}
[ searchField { databases:allDatabases
, langs
, onSearch
, search
, session
}
]
[ searchField { databases:allDatabases
, langs
, onSearch
, search
, session
}
]
src/Gargantext/Components/Search/SearchField.purs → src/Gargantext/Components/Forest/Tree/Node/Action/Search/SearchField.purs
View file @ 0b03d8c1
module Gargantext.Components.Search.SearchField
( Search, Props, defaultSearch, searchField, searchFieldComponent, isIsTex, isIsTex_Advanced) where
module Gargantext.Components.Forest.Tree.Node.Action.Search.SearchField
where
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust)
import DOM.Simple.Console (log, log2)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Nullable (null)
import Data.Newtype (over)
import Data.String (length)
import Data.Set as Set
import Data.Tuple (fst)
import Data.String (length)
import Data.Tuple.Nested ((/\))
import Data.Nullable (Nullable, toMaybe)
import Effect.Console (logShow)
import DOM.Simple.Console (log, log2)
import Effect.Aff (Aff, launchAff_)
import Effect.Class (liftEffect)
import Effect (Effect)
import Reactix as R
import Reactix.DOM.HTML as H
import Gargantext.Prelude (Unit, bind, const, discard, map, pure, show, ($), (&&), (<), (<$>), (<<<), (<>), (==))
import Gargantext.Data.Array (catMaybes)
import Effect.Aff (launchAff_)
import Effect.Class (liftEffect)
import Gargantext.Components.Forest.Tree.Node.Tools (panel)
import Gargantext.Components.Forest.Tree.Node.Action.Search.Types (DataField(..), Database(..), IMT_org(..), Org(..), SearchQuery(..), allIMTorgs, allOrgs, dataFields, defaultSearchQuery, doc, performSearch, datafield2database, Search)
import Gargantext.Components.Lang (Lang)
import Gargantext.Components.Search.Types (DataOriginApi(..), DataField(..), Database(..), IMT_org(..), Org(..), SearchQuery(..), allIMTorgs, allOrgs, dataFields, defaultSearchQuery, doc, performSearch, readDatabase, readOrg, datafield2database)
import Gargantext.Prelude (Unit, bind, discard, map, pure, show, ($), (<), (<$>), (<>), (==), read)
import Gargantext.Sessions (Session)
import Gargantext.Components.Forest.Tree.Node.Action.Search.Frame (searchIframes)
import Gargantext.Types as GT
import Gargantext.Utils.Reactix as R2
select :: forall props.
R.IsComponent String props (Array R.Element)
=> Record props
-> Array R.Element
-> R.Element
select = R.createElement "select"
type Search = { databases :: Database
, datafield :: Maybe DataField
, url :: String
, lang :: Maybe Lang
, node_id :: Maybe Int
, term :: String
}
eqSearch :: Search -> Search -> Boolean
eqSearch s s' = (s.databases == s'.databases)
&& (s.datafield == s'.datafield)
&& (s.lang == s'.lang)
&& (s.node_id == s'.node_id)
&& (s.term == s'.term)
import Reactix as R
import Reactix.DOM.HTML as H
defaultSearch :: Search
defaultSearch = { databases: Empty
......@@ -75,18 +50,15 @@ searchFieldComponent :: R.Component Props
searchFieldComponent = R.hooksComponent "G.C.S.SearchField" cpt
where
cpt props@{onSearch, search: search@(s /\ _)} _ = do
pure $
H.div { className: "search-field-group", style: { width: "100%" } }
[
H.div { className: "row" }
[
H.div { className: "col-md-12" }
iframeRef <- R.useRef null
let params =
[ searchInput {search}
, if length s.term < 3 -- search with love : <3
then
H.div {}[]
else
H.div {} [ dataFieldNav search dataFields
, if isExternal s.datafield
then databaseInput search props.databases
else H.div {} []
......@@ -102,46 +74,44 @@ searchFieldComponent = R.hooksComponent "G.C.S.SearchField" cpt
, if isCNRS s.datafield
then componentCNRS search
else H.div {} []
, H.div {} [ searchIframes search iframeRef ]
, if needsLang s.datafield
then langNav search props.langs
else H.div {} []
]
]
]
, H.div { className : "panel-footer" }
[ if needsLang s.datafield
then langNav search props.langs
else H.div {} []
, H.div {} []
, H.div {className: "flex-center"}
[submitButton {onSearch, search, session: props.session}]
]
]
eqProps :: Record Props -> Record Props -> Boolean
eqProps p p' = (p.databases == p'.databases )
&& (p.langs == p'.langs )
&& (eqSearch (fst p.search) (fst p'.search))
-- && (fst p.filters == fst p'.filters )
componentIMT (search /\ setSearch) =
R.fragment
[ H.ul {} $ map liCpt allIMTorgs
--, filterInput fi
]
where
liCpt org =
H.li {}
[ H.input { type: "checkbox"
, checked: isIn org search.datafield
, on: { change: \_ -> ( setSearch $ _ { datafield = updateFilter org search.datafield })
}
}
, if org == All_IMT
then H.i {} [H.text $ " " <> show org]
else H.text $ " " <> show org
]
componentCNRS (search /\ setSearch) =
R.fragment [
H.div {} []
--, filterInput fi
let button = submitButton {onSearch, search, session: props.session}
pure $ panel params button
componentIMT (search /\ setSearch) =
R.fragment
[ H.ul {} $ map liCpt allIMTorgs
--, filterInput fi
]
where
liCpt org =
H.li {}
[ H.input { type: "checkbox"
, checked: isIn org search.datafield
, on: { change: \_ -> ( setSearch $ _ { datafield = updateFilter org search.datafield })
}
}
, if org == All_IMT
then H.i {} [H.text $ " " <> show org]
else H.text $ " " <> show org
]
componentCNRS (search /\ setSearch) =
R.fragment [
H.div {} []
--, filterInput fi
]
isExternal :: Maybe DataField -> Boolean
isExternal (Just (External _)) = true
......@@ -165,16 +135,6 @@ isIsTex ( Just
) = true
isIsTex _ = false
isIsTex_Advanced :: Maybe DataField -> Boolean
isIsTex_Advanced ( Just
( External
( Just ( IsTex_Advanced)
)
)
) = true
isIsTex_Advanced _ = false
isIMT :: Maybe DataField -> Boolean
isIMT ( Just
......@@ -264,9 +224,11 @@ langNav ({lang} /\ setSearch) langs =
------------------------------------------------------------------------
dataFieldNav :: R.State Search -> Array DataField -> R.Element
dataFieldNav ({datafield} /\ setSearch) datafields =
R.fragment [ H.div {className: "text-primary center"} [H.text "with DataField"]
, H.div {className: "nav nav-tabs"} (liItem <$> dataFields)
, H.div {className: "center"} [ H.text $ maybe "" doc datafield ]
R.fragment [ H.div { className: "text-primary center"} [H.text "with DataField"]
, H.div {className: "nav nav-tabs"} (liItem <$> dataFields)
, H.div {className: "center"} [ H.text
$ maybe "TODO: add Doc Instance" doc datafield
]
]
where
liItem :: DataField -> R.Element
......@@ -276,9 +238,9 @@ dataFieldNav ({datafield} /\ setSearch) datafields =
then " active"
else ""
, on: { click: \_ -> setSearch $ _ { datafield = Just df'
, databases = datafield2database df'
, databases = datafield2database df'
}
}
}
-- just one database query for now
-- a list a selected database needs more ergonomy
} [ H.text (show df') ]
......@@ -326,7 +288,7 @@ databaseInput (search /\ setSearch) dbs =
liItem db' = H.option {className : "text-primary center"} [ H.text (show db') ]
onChange e = do
let value = readDatabase $ R2.unsafeEventValue e
let value = read $ R2.unsafeEventValue e
setSearch $ _ { datafield = Just $ External value
, databases = fromMaybe Empty value
}
......@@ -345,7 +307,7 @@ orgInput ({datafield} /\ setSearch) orgs =
liItem org = H.option {className : "text-primary center"} [ H.text (show org) ]
onChange e = do
let value = R2.unsafeEventValue e
setSearch $ _ { datafield = Just $ External $ Just $ HAL $ readOrg value }
setSearch $ _ { datafield = Just $ External $ Just $ HAL $ read value }
{-
filterInput :: R.State String -> R.Element
......@@ -392,8 +354,8 @@ searchInputComponent = R.hooksComponent "G.C.S.SearchInput" cpt
type SubmitButtonProps =
( onSearch :: GT.AsyncTaskWithType -> Effect Unit
, search :: R.State Search
, session :: Session
, search :: R.State Search
, session :: Session
)
submitButton :: Record SubmitButtonProps -> R.Element
......
src/Gargantext/Components/Search/Types.purs → src/Gargantext/Components/Forest/Tree/Node/Action/Search/Types.purs
View file @ 0b03d8c1
module Gargantext.Components.Search.Types where
module Gargantext.Components.Forest.Tree.Node.Action.Search.Types where
import Data.Array (concat)
import Data.Argonaut (class EncodeJson, encodeJson, jsonEmptyObject, (:=), (~>))
import Data.Array (concat)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Newtype (class Newtype)
import Data.Set (Set)
......@@ -9,17 +9,33 @@ import Data.Set as Set
import Data.Tuple (Tuple)
import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff)
import URI.Extra.QueryPairs as QP
import URI.Query as Q
import Gargantext.Prelude (class Eq, class Ord, class Show, bind, map, pure, show, ($), (<>))
import Gargantext.Components.Lang
import Gargantext.Ends (class ToUrl, backendUrl)
import Gargantext.Prelude (id, class Eq, class Ord, class Show, bind, map, pure, show, ($), (<>), class Read)
import Gargantext.Routes as GR
import Gargantext.Sessions (Session(..), post)
import Gargantext.Types as GT
import Gargantext.Utils (id)
import URI.Extra.QueryPairs as QP
import URI.Query as Q
type Search = { databases :: Database
, datafield :: Maybe DataField
, url :: String
, lang :: Maybe Lang
, node_id :: Maybe Int
, term :: String
}
isIsTex_Advanced :: Maybe DataField -> Boolean
isIsTex_Advanced ( Just
( External
( Just ( IsTex_Advanced)
)
)
) = true
isIsTex_Advanced _ = false
------------------------------------------------------------------------
class Doc a where
......@@ -130,17 +146,18 @@ instance docDatabase :: Doc Database where
-- doc News = "Web filtered by News"
-- doc SocialNetworks = "Web filtered by MicroBlogs"
readDatabase :: String -> Maybe Database
readDatabase "All Databases" = Just All_Databases
readDatabase "PubMed" = Just PubMed
readDatabase "HAL" = Just $ HAL Nothing
readDatabase "Isidore"= Just Isidore
readDatabase "IsTex" = Just IsTex
readDatabase "IsTex_Advanced" = Just IsTex_Advanced
-- readDatabase "Web" = Just Web
-- readDatabase "News" = Just News
-- readDatabase "Social Networks" = Just SocialNetworks
readDatabase _ = Nothing
instance readDatabase :: Read Database where
read :: String -> Maybe Database
read "All Databases" = Just All_Databases
read "PubMed" = Just PubMed
read "HAL" = Just $ HAL Nothing
read "Isidore"= Just Isidore
read "IsTex" = Just IsTex
read "IsTex_Advanced" = Just IsTex_Advanced
-- read "Web" = Just Web
-- read "News" = Just News
-- read "Social Networks" = Just SocialNetworks
read _ = Nothing
derive instance eqDatabase :: Eq Database
......@@ -169,12 +186,12 @@ instance showOrg :: Show Org where
show (IMT _) = "IMT"
show (Others _) = "Others"
readOrg :: String -> Maybe Org
readOrg "All_Orgs" = Just $ All_Orgs
readOrg "CNRS" = Just $ CNRS $ Set.fromFoldable []
readOrg "IMT" = Just $ IMT $ Set.fromFoldable []
readOrg "Others" = Just $ Others $ Set.fromFoldable []
readOrg _ = Nothing
instance readOrg :: Read Org where
read "All_Orgs" = Just $ All_Orgs
read "CNRS" = Just $ CNRS $ Set.fromFoldable []
read "IMT" = Just $ IMT $ Set.fromFoldable []
read "Others" = Just $ Others $ Set.fromFoldable []
read _ = Nothing
derive instance eqOrg :: Eq Org
......@@ -248,26 +265,26 @@ instance showIMT_org :: Show IMT_org where
show Telecom_ParisTech = "Telecom_ParisTech"
show Telecom_SudParis = "Telecom_SudParis"
readIMT_org :: String -> Maybe IMT_org
readIMT_org "All_IMT" = Just All_IMT
readIMT_org "ARMINES" = Just ARMINES
readIMT_org "Eurecom" = Just Eurecom
readIMT_org "IMT_Atlantique" = Just IMT_Atlantique
readIMT_org "IMT_Business_School" = Just IMT_Business_School
readIMT_org "IMT_Lille_Douai" = Just IMT_Lille_Douai
readIMT_org "IMT_Mines_ALES" = Just IMT_Mines_ALES
readIMT_org "IMT_Mines_Albi" = Just IMT_Mines_Albi
readIMT_org "Institut_MinesTelecom_Paris" = Just Institut_MinesTelecom_Paris
readIMT_org "MINES_ParisTech" = Just MINES_ParisTech
readIMT_org "Mines_Douai" = Just Mines_Douai
readIMT_org "Mines_Nantes" = Just Mines_Nantes
readIMT_org "Mines_SaintEtienne" = Just Mines_SaintEtienne
readIMT_org "Telecom_Bretagne" = Just Telecom_Bretagne
readIMT_org "Telecom_Ecole_de_Management" = Just Telecom_Ecole_de_Management
readIMT_org "Telecom_Lille" = Just Telecom_Lille
readIMT_org "Telecom_ParisTech" = Just Telecom_ParisTech
readIMT_org "Telecom_SudParis" = Just Telecom_SudParis
readIMT_org _ = Nothing
instance readIMT_org :: Read IMT_org where
read "All_IMT" = Just All_IMT
read "ARMINES" = Just ARMINES
read "Eurecom" = Just Eurecom
read "IMT_Atlantique" = Just IMT_Atlantique
read "IMT_Business_School" = Just IMT_Business_School
read "IMT_Lille_Douai" = Just IMT_Lille_Douai
read "IMT_Mines_ALES" = Just IMT_Mines_ALES
read "IMT_Mines_Albi" = Just IMT_Mines_Albi
read "Institut_MinesTelecom_Paris" = Just Institut_MinesTelecom_Paris
read "MINES_ParisTech" = Just MINES_ParisTech
read "Mines_Douai" = Just Mines_Douai
read "Mines_Nantes" = Just Mines_Nantes
read "Mines_SaintEtienne" = Just Mines_SaintEtienne
read "Telecom_Bretagne" = Just Telecom_Bretagne
read "Telecom_Ecole_de_Management" = Just Telecom_Ecole_de_Management
read "Telecom_Lille" = Just Telecom_Lille
read "Telecom_ParisTech" = Just Telecom_ParisTech
read "Telecom_SudParis" = Just Telecom_SudParis
read _ = Nothing
imtStructId :: IMT_org -> Array StructId
imtStructId All_IMT = concat $ map imtStructId allIMTSubOrgs
......
src/Gargantext/Components/Forest/Tree/Node/Action/Share.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Share where
import Data.Argonaut (class EncodeJson, jsonEmptyObject, (:=), (~>))
import Data.Maybe (Maybe(..))
import Effect.Aff (Aff)
import Prelude (($))
import Reactix as R
import Gargantext.Components.Forest.Tree.Node.Action
import Gargantext.Types as GT
import Gargantext.Types (ID)
import Gargantext.Routes as GR
import Gargantext.Sessions (Session, post)
import Gargantext.Components.Forest.Tree.Node.Tools as Tools
------------------------------------------------------------------------
share :: Session -> ID -> ShareValue -> Aff (Array ID)
share session nodeId =
post session $ GR.NodeAPI GT.Node (Just nodeId) "share"
shareAction :: String -> Action
shareAction username = ShareNode username
------------------------------------------------------------------------
newtype ShareValue = ShareValue
{ text :: String }
instance encodeJsonShareValue :: EncodeJson ShareValue where
encodeJson (ShareValue {text})
= "username" := text
~> jsonEmptyObject
------------------------------------------------------------------------
textInputBox :: Record Tools.TextInputBoxProps -> R.Element
textInputBox = Tools.textInputBox
src/Gargantext/Components/Forest/Tree/Node/Action/Update.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Update where
import Data.Array (length, head)
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, jsonEmptyObject, (.:), (:=), (~>))
import Data.Maybe (Maybe(..), fromMaybe)
-- import Data.Newtype (class Newtype)
import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff, launchAff)
import Effect.Uncurried (mkEffectFn1)
import Data.Maybe (Maybe(..))
import Effect.Aff (Aff)
import Gargantext.Components.Forest.Tree.Node.Action (Action(..))
import Gargantext.Components.Forest.Tree.Node (SettingsBox(..), settingsBox)
import Gargantext.Types (NodeType(..), readNodeType)
import Gargantext.Utils.Reactix as R2
import Gargantext.Components.Forest.Tree.Node.Action.Update.Types
import Gargantext.Components.Forest.Tree.Node.Tools (formChoiceSafe, submitButton, panel)
import Gargantext.Types (NodeType(..), ID)
import Gargantext.Types as GT
import Gargantext.Prelude (Unit, bind, ($), pure)
import Gargantext.Sessions (Session, post)
import Gargantext.Routes as GR
import Gargantext.Types as GT
import Prelude (Unit, bind, const, discard, map, pure, show, ($), (<>), (>), (<<<))
import Reactix as R
import Reactix.DOM.HTML as H
{-
updateNode :: Session -> ID -> UpdateNodeParams -> Aff (Array ID)
updateNode session nodeId params = post session $ GR.NodeAPI GT.Node (Just nodeId) ""
-}
data UpdateNodeParams = UpdateNodeParamsList { method :: Int }
| UpdateNodeParamsGraph { method :: String }
| UpdateNodeParamsTexts { method :: Int }
instance encodeJsonUpdateNodeParams :: EncodeJson UpdateNodeParams
where
encodeJson (UpdateNodeParamsList { method })
= "method" := method
~> jsonEmptyObject
encodeJson (UpdateNodeParamsGraph { method })
= "method" := method
~> jsonEmptyObject
encodeJson (UpdateNodeParamsTexts { method })
= "method" := method
~> jsonEmptyObject
updateRequest :: UpdateNodeParams -> Session -> ID -> Aff GT.AsyncTaskWithType
updateRequest (UpdateNodeParamsList meth) session nodeId = do
task <- post session p meth
pure $ GT.AsyncTaskWithType {task, typ: GT.UpdateNode }
where
p = GR.NodeAPI GT.Node (Just nodeId) "update/nobody"
updateRequest (UpdateNodeParamsGraph meth) session nodeId = do
task <- post session p meth
pure $ GT.AsyncTaskWithType {task, typ: GT.UpdateNode }
where
p = GR.NodeAPI GT.Node (Just nodeId) "update/nobody"
updateRequest (UpdateNodeParamsTexts meth) session nodeId = do
task <- post session p meth
pure $ GT.AsyncTaskWithType {task, typ: GT.UpdateNode }
where
p = GR.NodeAPI GT.Node (Just nodeId) "update/nobody"
updateRequest (UpdateNodeParamsBoard meth) session nodeId = do
task <- post session p meth
pure $ GT.AsyncTaskWithType {task, typ: GT.UpdateNode }
where
p = GR.NodeAPI GT.Node (Just nodeId) "update/nobody"
----------------------------------------------------------------------
type UpdateNodeProps =
( id :: GT.ID
, dispatch :: Action -> Aff Unit
, name :: GT.Name
, nodeType :: NodeType
, params :: UpdateNodeParams
)
update :: NodeType
-> (Action -> Aff Unit)
-> R.Hooks R.Element
update NodeList dispatch = do
meth @( methodList /\ setMethod ) <- R.useState' Basic
pure $ panel [ -- H.text "Update with"
formChoiceSafe [Basic, Advanced, WithModel] Basic setMethod
]
(submitButton (UpdateNode $ UpdateNodeParamsList {methodList}) dispatch)
update Graph dispatch = do
meth @( methodGraph /\ setMethod ) <- R.useState' Order1
pure $ panel [ -- H.text "Update with"
formChoiceSafe [Order1, Order2] Order1 setMethod
]
(submitButton (UpdateNode $ UpdateNodeParamsGraph {methodGraph}) dispatch)
update Texts dispatch = do
meth @( methodTexts /\ setMethod ) <- R.useState' NewNgrams
pure $ panel [ -- H.text "Update with"
formChoiceSafe [NewNgrams, NewTexts, Both] NewNgrams setMethod
]
(submitButton (UpdateNode $ UpdateNodeParamsTexts {methodTexts}) dispatch)
update Dashboard dispatch = do
meth @( methodBoard /\ setMethod ) <- R.useState' All
pure $ panel [ -- H.text "Update with"
formChoiceSafe [All, Sources, Authors, Institutes, Ngrams] All setMethod
]
(submitButton (UpdateNode $ UpdateNodeParamsBoard {methodBoard}) dispatch)
update _ _ = pure $ H.div {} []
-- fragmentPT $ "Update " <> show nodeType
src/Gargantext/Components/Forest/Tree/Node/Action/Update/Types.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Update.Types where
import Data.Argonaut as Argonaut
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Gargantext.Utils.Argonaut (genericSumDecodeJson, genericSumEncodeJson, genericEnumDecodeJson, genericEnumEncodeJson)
import Data.Maybe (Maybe(..))
import Gargantext.Prelude (class Eq, class Read, class Show)
data UpdateNodeParams = UpdateNodeParamsList { methodList :: Method }
| UpdateNodeParamsGraph { methodGraph :: GraphMetric }
| UpdateNodeParamsTexts { methodTexts :: Granularity }
| UpdateNodeParamsBoard { methodBoard :: Charts }
derive instance eqUpdateNodeParams :: Eq UpdateNodeParams
derive instance genericUpdateNodeParams :: Generic UpdateNodeParams _
instance showUpdateNodeParams :: Show UpdateNodeParams where
show = genericShow
instance decodeJsonUpdateNodeParams :: Argonaut.DecodeJson UpdateNodeParams where
decodeJson = genericSumDecodeJson
instance encodeJsonUpdateNodeParams :: Argonaut.EncodeJson UpdateNodeParams where
encodeJson = genericSumEncodeJson
----------------------------------------------------------------------
data Method = Basic | Advanced | WithModel
derive instance genericMethod :: Generic Method _
derive instance eqMethod :: Eq Method
instance showMethod :: Show Method where
show = genericShow
instance readMethod :: Read Method where
read "Basic" = Just Basic
read "Advanced" = Just Advanced
read "WithModel" = Just WithModel
read _ = Nothing
instance decodeJsonMethod :: Argonaut.DecodeJson Method where
decodeJson = genericEnumDecodeJson
instance encodeJsonMethod :: Argonaut.EncodeJson Method where
encodeJson = genericEnumEncodeJson
----------------------------------------------------------------------
data GraphMetric = Order1 | Order2
derive instance genericGraphMetric :: Generic GraphMetric _
derive instance eqGraphMetric :: Eq GraphMetric
instance showGraphMetric :: Show GraphMetric where
show = genericShow
instance readGraphMetric :: Read GraphMetric where
read "Order1" = Just Order1
read "Order2" = Just Order2
read _ = Nothing
instance decodeJsonGraphMetric :: Argonaut.DecodeJson GraphMetric where
decodeJson = genericEnumDecodeJson
instance encodeJsonGraphMetric :: Argonaut.EncodeJson GraphMetric where
encodeJson = genericEnumEncodeJson
----------------------------------------------------------------------
data Granularity = NewNgrams | NewTexts | Both
derive instance genericGranularity :: Generic Granularity _
derive instance eqGranularity :: Eq Granularity
instance showGranularity :: Show Granularity where
show = genericShow
instance readGranularity :: Read Granularity where
read "NewNgrams" = Just NewNgrams
read "NewTexts" = Just NewTexts
read "Both" = Just Both
read _ = Nothing
instance decodeJsonGranularity :: Argonaut.DecodeJson Granularity where
decodeJson = genericEnumDecodeJson
instance encodeJsonGranularity :: Argonaut.EncodeJson Granularity where
encodeJson = genericEnumEncodeJson
----------------------------------------------------------------------
data Charts = Sources | Authors | Institutes | Ngrams | All
derive instance genericChart :: Generic Charts _
derive instance eqChart :: Eq Charts
instance showChart :: Show Charts where
show = genericShow
instance readChart :: Read Charts where
read "Sources " = Just Sources
read "Authors" = Just Authors
read "Institutes" = Just Institutes
read "Ngrams" = Just Ngrams
read "AllCharts" = Just All
read _ = Nothing
instance decodeJsonChart :: Argonaut.DecodeJson Charts where
decodeJson = genericEnumDecodeJson
instance encodeJsonChart :: Argonaut.EncodeJson Charts where
encodeJson = genericEnumEncodeJson
src/Gargantext/Components/Forest/Tree/Node/Action/Upload.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Upload where
import Data.Array as A
import Data.Maybe (Maybe(..), fromJust)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import DOM.Simple.Console (log2)
import Effect (Effect)
import Effect.Aff (Aff, launchAff)
import Effect.Class (liftEffect)
import Effect (Effect)
import Gargantext.Components.Forest.Tree.Node.Action (Action(..), Props)
import Gargantext.Components.Forest.Tree.Node.Action.Upload.Types (FileType(..), UploadFileContents(..))
import Gargantext.Components.Forest.Tree.Node.Tools (fragmentPT, formChoiceSafe, panel)
import Gargantext.Components.Lang (Lang(..))
import Gargantext.Prelude (class Show, Unit, discard, bind, const, id, map, pure, show, unit, void, ($), read)
import Gargantext.Routes as GR
import Gargantext.Sessions (Session, postWwwUrlencoded)
import Gargantext.Types (NodeType(..), ID)
import Gargantext.Types as GT
import Gargantext.Utils.Reactix as R2
import Partial.Unsafe (unsafePartial)
import React.SyntheticEvent as E
import Reactix as R
import Reactix.DOM.HTML as H
import URI.Extra.QueryPairs as QP
import React.SyntheticEvent as E
import Reactix as R
import Reactix.DOM.HTML as H
import URI.Extra.QueryPairs as QP
import Web.File.FileReader.Aff (readAsText)
import Gargantext.Prelude (class Show, Unit, bind, const, discard, map, pure, show, unit, void, ($), (&&), (/=), (<>))
-- UploadFile Action
-- | Action : Upload
actionUpload :: NodeType -> ID -> Session -> (Action -> Aff Unit) -> R.Hooks R.Element
actionUpload NodeList id session dispatch =
pure $ uploadTermListView {dispatch, id, nodeType: GT.NodeList, session}
actionUpload Corpus id session dispatch =
pure $ uploadFileView {dispatch, id, nodeType: Corpus, session}
actionUpload _ _ _ _ =
pure $ fragmentPT $ "Soon, upload for this NodeType."
import Gargantext.Components.Lang (readLang, Lang(..))
import Gargantext.Components.Forest.Tree.Node.Action (Action(..), Props, FileType(..), UploadFileContents(..))
import Gargantext.Components.Forest.Tree.Node.FTree (FTree, ID, LNode(..), NTree(..))
import Gargantext.Hooks.Loader (useLoader)
import Gargantext.Routes as GR
import Gargantext.Sessions (Session(..), postWwwUrlencoded, get)
import Gargantext.Types as GT
import Gargantext.Utils (id)
import Gargantext.Utils.Reactix as R2
-- UploadFile Action
-- file upload types
data DroppedFile =
DroppedFile { contents :: UploadFileContents
, fileType :: Maybe FileType
, lang :: Maybe Lang
, lang :: Lang
}
type FileHash = String
......@@ -53,35 +62,36 @@ uploadFileViewCpt = R.hooksComponent "G.C.F.T.N.A.U.UploadFileView" cpt
where
cpt {dispatch, id, nodeType} _ = do
mFile :: R.State (Maybe UploadFile) <- R.useState' Nothing
fileType :: R.State FileType <- R.useState' CSV
lang :: R.State (Maybe Lang) <- R.useState' (Just EN)
pure $ H.div {} [
H.div {} [ H.input { type: "file"
, placeholder: "Choose file"
, on: {change: onChangeContents mFile}
}
]
, H.div {} [ R2.select {className: "col-md-12 form-control"
, on: {change: onChangeFileType fileType}
}
( map renderOptionFT [ CSV
, CSV_HAL
, WOS
, PresseRIS
]
)
]
, H.div {} [ R2.select {className: "col-md-12 form-control"
, on: {change: onChangeLang lang}
} (map renderOptionLang [EN, FR])
]
, H.div {} [ uploadButton {dispatch, fileType, lang, id, mFile, nodeType } ]
]
fileType@(_ /\ setFileType) <- R.useState' CSV
lang@( _chosenLang /\ setLang) <- R.useState' EN
let bodies = [ H.div { className:"col-md-6 flex-space-around"}
[ H.input { type: "file"
, placeholder: "Choose file"
, on: {change: onChangeContents mFile}
}
]
, H.div {className:"col-md-3 flex-space-around"}
[ formChoiceSafe [ CSV
, CSV_HAL
, WOS
, PresseRIS
] CSV setFileType
]
, H.div {className:"col-md-3 flex-space-around"}
[ formChoiceSafe [EN, FR, No_extraction, Universal] EN setLang ]
]
let footer = H.div {} [ uploadButton { dispatch
, fileType
, lang
, id
, mFile
, nodeType
}
]
pure $ panel bodies footer
renderOptionFT :: FileType -> R.Element
renderOptionFT opt = H.option {} [ H.text $ show opt ]
......@@ -101,27 +111,23 @@ uploadFileViewCpt = R.hooksComponent "G.C.F.T.N.A.U.UploadFileView" cpt
liftEffect $ do
setMFile $ const $ Just $ {contents: UploadFileContents contents, name}
onChangeFileType :: forall e. R.State FileType -> e -> Effect Unit
onChangeFileType :: forall e
. R.State FileType
-> e
-> Effect Unit
onChangeFileType (fileType /\ setFileType) e = do
setFileType $ const
$ unsafePartial
$ fromJust
$ readFileType
$ read
$ R2.unsafeEventValue e
onChangeLang :: forall e. R.State (Maybe Lang) -> e -> Effect Unit
onChangeLang (lang /\ setLang) e = do
setLang $ const
$ unsafePartial
$ readLang
$ R2.unsafeEventValue e
type UploadButtonProps =
( dispatch :: Action -> Aff Unit
, fileType :: R.State FileType
, id :: GT.ID
, lang :: R.State (Maybe Lang)
, lang :: R.State Lang
, mFile :: R.State (Maybe UploadFile)
, nodeType :: GT.NodeType
)
......@@ -132,12 +138,23 @@ uploadButton props = R.createElement uploadButtonCpt props []
uploadButtonCpt :: R.Component UploadButtonProps
uploadButtonCpt = R.hooksComponent "G.C.F.T.N.A.U.uploadButton" cpt
where
cpt {dispatch, fileType: (fileType /\ setFileType), id, lang: (lang /\ setLang), mFile: (mFile /\ setMFile), nodeType} _ = do
pure $ H.button {className: "btn btn-primary", disabled, on: {click: onClick}} [ H.text "Upload" ]
cpt { dispatch
, fileType: (fileType /\ setFileType)
, id
, lang: (lang /\ setLang)
, mFile: (mFile /\ setMFile)
, nodeType
} _ = pure
$ H.button { className: "btn btn-primary"
, "type" : "button"
, disabled
, style : { width: "100%" }
, on: {click: onClick}
} [ H.text "Upload" ]
where
disabled = case mFile of
Nothing -> "1"
Just _ -> ""
Just _ -> ""
onClick e = do
let {name, contents} = unsafePartial $ fromJust mFile
......@@ -146,7 +163,7 @@ uploadButtonCpt = R.hooksComponent "G.C.F.T.N.A.U.uploadButton" cpt
liftEffect $ do
setMFile $ const $ Nothing
setFileType $ const $ CSV
setLang $ const $ Just EN
setLang $ const $ EN
-- START File Type View
type FileTypeProps =
......@@ -163,19 +180,24 @@ fileTypeView p = R.createElement fileTypeViewCpt p []
fileTypeViewCpt :: R.Component FileTypeProps
fileTypeViewCpt = R.hooksComponent "G.C.F.T.N.A.U.fileTypeView" cpt
where
cpt {dispatch, droppedFile: (Just (DroppedFile {contents, fileType}) /\ setDroppedFile), isDragOver: (_ /\ setIsDragOver), nodeType} _ = do
pure $ H.div tooltipProps $
[ H.div {className: "panel panel-default"}
[ panelHeading
, panelBody
, panelFooter
]
]
cpt { dispatch
, droppedFile: Just (DroppedFile {contents, fileType}) /\ setDroppedFile
, isDragOver: (_ /\ setIsDragOver)
, nodeType
} _ = pure
$ H.div tooltipProps [ H.div { className: "panel panel-default"}
[ panelHeading
, panelBody
, panelFooter
]
]
where
tooltipProps = { className: ""
, id: "file-type-tooltip"
, title: "Choose file type"
, data: {toggle: "tooltip", placement: "right"}
, id : "file-type-tooltip"
, title : "Choose file type"
, data : { toggle: "tooltip"
, placement: "right"
}
}
panelHeading =
H.div {className: "panel-heading"}
......@@ -186,26 +208,28 @@ fileTypeViewCpt = R.hooksComponent "G.C.F.T.N.A.U.fileTypeView" cpt
[ H.a {className: "btn glyphitem glyphicon glyphicon-remove-circle"
, on: {click: \_ -> do
setDroppedFile $ const Nothing
setIsDragOver $ const false
setIsDragOver $ const false
}
, title: "Close"} []
]
]
]
panelBody =
H.div {className: "panel-body"}
[ R2.select {className: "col-md-12 form-control"
, on: {change: onChange}
}
(map renderOption [CSV, CSV_HAL, WOS])
(map renderOption [CSV, CSV_HAL, WOS])
]
where
onChange e l =
setDroppedFile $ const $ Just $ DroppedFile $ { contents
, fileType: readFileType $ R2.unsafeEventValue e
, lang : readLang $ R2.unsafeEventValue l
, fileType: read $ R2.unsafeEventValue e
, lang : fromMaybe EN $ read $ R2.unsafeEventValue l
}
renderOption opt = H.option {} [ H.text $ show opt ]
renderOption opt = H.option {} [ H.text $ show opt ]
panelFooter =
H.div {className: "panel-footer"}
[
......@@ -253,11 +277,12 @@ uploadFile session nodeType id fileType {mName, contents: UploadFileContents con
q = FileUploadQuery { fileType: fileType }
--p = NodeAPI GT.Corpus (Just id) $ "add/file/async/nobody" <> Q.print (toQuery q)
p = GR.NodeAPI nodeType (Just id) $ GT.asyncTaskTypePath GT.Form
bodyParams = [
Tuple "_wf_data" (Just contents)
, Tuple "_wf_filetype" (Just $ show fileType)
, Tuple "_wf_name" mName
]
bodyParams = [ Tuple "_wf_data" (Just contents)
, Tuple "_wf_filetype" (Just $ show fileType)
, Tuple "_wf_name" mName
]
------------------------------------------------------------------------
uploadTermListView :: Record Props -> R.Element
uploadTermListView props = R.createElement uploadTermListViewCpt props []
......@@ -267,18 +292,23 @@ uploadTermListViewCpt = R.hooksComponent "G.C.F.T.N.A.U.UploadTermListView" cpt
where
cpt {dispatch, id, nodeType} _ = do
mFile :: R.State (Maybe UploadFile) <- R.useState' Nothing
pure $ H.div {} [
H.div {} [ H.input { type: "file"
let body = H.input { type: "file"
, placeholder: "Choose file"
, on: {change: onChangeContents mFile}
}
]
, H.div {} [ uploadTermButton { dispatch, id, mFile, nodeType } ]
]
let footer = H.div {} [ uploadTermButton { dispatch
, id
, mFile
, nodeType
}
]
onChangeContents :: forall e. R.State (Maybe UploadFile) -> E.SyntheticEvent_ e -> Effect Unit
pure $ panel [body] footer
onChangeContents :: forall e. R.State (Maybe UploadFile)
-> E.SyntheticEvent_ e
-> Effect Unit
onChangeContents (mFile /\ setMFile) e = do
let mF = R2.inputFileNameWithBlob 0 e
E.preventDefault e
......@@ -288,7 +318,9 @@ uploadTermListViewCpt = R.hooksComponent "G.C.F.T.N.A.U.UploadTermListView" cpt
Just {blob, name} -> void $ launchAff do
contents <- readAsText blob
liftEffect $ do
setMFile $ const $ Just $ {contents: UploadFileContents contents, name}
setMFile $ const $ Just $ { contents: UploadFileContents contents
, name
}
type UploadTermButtonProps =
......@@ -309,7 +341,7 @@ uploadTermButtonCpt = R.hooksComponent "G.C.F.T.N.A.U.uploadTermButton" cpt
where
disabled = case mFile of
Nothing -> "1"
Just _ -> ""
Just _ -> ""
onClick e = do
let {name, contents} = unsafePartial $ fromJust mFile
......@@ -319,13 +351,4 @@ uploadTermButtonCpt = R.hooksComponent "G.C.F.T.N.A.U.uploadTermButton" cpt
setMFile $ const $ Nothing
-- | UTils
readFileType :: String -> Maybe FileType
readFileType "CSV" = Just CSV
readFileType "CSV_HAL" = Just CSV_HAL
readFileType "PresseRIS" = Just PresseRIS
readFileType "WOS" = Just WOS
readFileType _ = Nothing
src/Gargantext/Components/Forest/Tree/Node/Action/Upload/Types.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Action.Upload.Types where
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..))
import Gargantext.Prelude (class Read, class Show, class Eq)
data FileType = CSV | CSV_HAL | WOS | PresseRIS
derive instance genericFileType :: Generic FileType _
instance eqFileType :: Eq FileType where
eq = genericEq
instance showFileType :: Show FileType where
show = genericShow
instance readFileType :: Read FileType where
read :: String -> Maybe FileType
read "CSV" = Just CSV
read "CSV_HAL" = Just CSV_HAL
read "PresseRIS" = Just PresseRIS
read "WOS" = Just WOS
read _ = Nothing
newtype UploadFileContents = UploadFileContents String
src/Gargantext/Components/Forest/Tree/Node/Box.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Box where
import Data.Array as A
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Nullable (Nullable, null)
import Data.Tuple (fst, Tuple(..))
import Data.Maybe (Maybe(..))
import Data.String as S
import Data.Tuple.Nested ((/\))
import DOM.Simple as DOM
import DOM.Simple.Event
import DOM.Simple.EventListener
import DOM.Simple.Types
import DOM.Simple.Window
import Effect (Effect)
import Effect.Aff (Aff, launchAff, launchAff_)
import Effect.Class (liftEffect)
import Effect.Console
import Effect.Aff (Aff)
import Effect.Uncurried (mkEffectFn1)
import React.SyntheticEvent as E
import Reactix as R
import Reactix.DOM.HTML as H
import URI.Extra.QueryPairs as NQP
import URI.Query as Query
import Web.File.FileReader.Aff (readAsText)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Forest.Tree.Node (NodeAction(..), SettingsBox(..), glyphiconNodeAction, settingsBox)
import Gargantext.Components.Forest.Tree.Node.Action (Action(..), FileType(..), UploadFileContents(..))
import Gargantext.Prelude
import Gargantext.Components.Forest.Tree.Node.Action (Action)
import Gargantext.Components.Forest.Tree.Node.Action.Add (NodePopup(..), addNodeView)
import Gargantext.Components.Forest.Tree.Node.Action.CopyFrom (copyFromCorpusView)
import Gargantext.Components.Forest.Tree.Node.Action.Rename (renameBox)
import Gargantext.Components.Forest.Tree.Node.Action.Update
import Gargantext.Components.Forest.Tree.Node.Action.Upload (DroppedFile(..), uploadFileView, fileTypeView, uploadTermListView)
import Gargantext.Components.Forest.Tree.Node.ProgressBar (asyncProgressBar, BarType(..))
import Gargantext.Components.GraphExplorer.API as GraphAPI
import Gargantext.Components.Lang (allLangs, Lang(EN))
import Gargantext.Components.NgramsTable.API as NTAPI
import Gargantext.Components.Nodes.Corpus (loadCorpusWithChild)
import Gargantext.Components.Search.SearchBar (searchBar)
import Gargantext.Components.Search.SearchField (Search, defaultSearch, isIsTex_Advanced)
import Gargantext.Components.Search.Types (DataField(..))
import Gargantext.Ends (Frontends, url)
import Gargantext.Hooks.Loader (useLoader)
import Gargantext.Prelude
import Gargantext.Routes as Routes
import Gargantext.Sessions (Session, sessionId, post)
import Gargantext.Types (NodeType(..), ID, Name, Reload)
import Gargantext.Components.Forest.Tree.Node.Action.Delete (actionDelete)
import Gargantext.Components.Forest.Tree.Node.Action.Documentation (actionDoc)
import Gargantext.Components.Forest.Tree.Node.Action.Download (actionDownload)
import Gargantext.Components.Forest.Tree.Node.Action.Rename (renameAction)
import Gargantext.Components.Forest.Tree.Node.Action.Search (actionSearch)
import Gargantext.Components.Forest.Tree.Node.Action.Search.SearchField (defaultSearch)
import Gargantext.Components.Forest.Tree.Node.Action.Share as Share
import Gargantext.Components.Forest.Tree.Node.Action.Update (update)
import Gargantext.Components.Forest.Tree.Node.Action.Upload (actionUpload)
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.Tools (textInputBox, fragmentPT)
import Gargantext.Sessions (Session)
import Gargantext.Types (Name, ID)
import Gargantext.Types as GT
import Gargantext.Utils (glyphicon, glyphiconActive)
import Gargantext.Utils.Popover as Popover
import Gargantext.Utils.Reactix as R2
type Tasks =
( onTaskAdd :: GT.AsyncTaskWithType -> Effect Unit
, onTaskFinish :: GT.AsyncTaskWithType -> Effect Unit
, tasks :: Array GT.AsyncTaskWithType
)
tasksStruct :: Int -> R.State GAT.Storage -> R.State Reload -> Record Tasks
tasksStruct id (asyncTasks /\ setAsyncTasks) (_ /\ setReload) = { onTaskAdd, onTaskFinish, tasks }
where
tasks = fromMaybe [] $ Map.lookup id asyncTasks
onTaskAdd t = do
setReload (_ + 1)
setAsyncTasks $ Map.alter (maybe (Just [t]) $ (\ts -> Just $ A.cons t ts)) id
onTaskFinish t = do
setReload (_ + 1)
setAsyncTasks $ Map.alter (maybe Nothing $ (\ts -> Just $ GAT.removeTaskFromList ts t)) id
type CommonProps =
( dispatch :: Action -> Aff Unit
, session :: Session
)
-- Main Node
type NodeMainSpanProps =
( id :: ID
, folderOpen :: R.State Boolean
, frontends :: Frontends
, mCurrentRoute :: Maybe Routes.AppRoute
, name :: Name
, nodeType :: GT.NodeType
, tasks :: Record Tasks
| CommonProps
)
nodeMainSpan :: Record NodeMainSpanProps
-> R.Element
nodeMainSpan p@{ dispatch, folderOpen, frontends, session } = R.createElement el p []
where
el = R.hooksComponent "G.C.F.T.N.B.NodeMainSpan" cpt
cpt props@{id, mCurrentRoute, name, nodeType, tasks: { onTaskFinish, tasks }} _ = do
-- only 1 popup at a time is allowed to be opened
droppedFile <- R.useState' (Nothing :: Maybe DroppedFile)
isDragOver <- R.useState' false
popoverRef <- R.useRef null
pure $ H.span (dropProps droppedFile isDragOver) $
[ folderIcon nodeType folderOpen
, if showBox then
Popover.popover { arrow: false
, open: false
, onClose: \_ -> pure unit
, onOpen: \_ -> pure unit
, ref: popoverRef } [
popOverIcon
, mNodePopupView props (onPopoverClose popoverRef)
]
else H.div {} []
, H.a { href: (url frontends (GT.NodePath (sessionId session) nodeType (Just id)))
}
[ nodeText { isSelected: mAppRouteId mCurrentRoute == Just id
, name: name' props
} ]
, nodeActions { id
, nodeType
, refreshTree: const $ dispatch RefreshTree
, session }
, fileTypeView {dispatch, droppedFile, id, isDragOver, nodeType}
, H.div {} (map (\t -> asyncProgressBar { asyncTask: t
, barType: Pie
, corpusId: id
, onFinish: const $ onTaskFinish t
, session }) tasks)
]
where
SettingsBox {show: showBox} = settingsBox nodeType
onPopoverClose popoverRef _ = do
Popover.setOpen popoverRef false
name' {name, nodeType} = if nodeType == GT.NodeUser then show session else name
folderIcon nodeType folderOpen'@(open /\ _) =
H.a { className: "folder-icon"
, onClick: R2.effToggler folderOpen' }
[ H.i {className: GT.fldr nodeType open} [] ]
popOverIcon =
H.a { className: "settings fa fa-cog" } []
mNodePopupView props@{id, nodeType} onPopoverClose =
nodePopupView { id
, dispatch
, name: name' props
, nodeType
, onPopoverClose
, session
}
dropProps droppedFile isDragOver =
{ className: "leaf " <> (dropClass droppedFile isDragOver)
, on: { drop: dropHandler droppedFile
, dragOver: onDragOverHandler isDragOver
, dragLeave: onDragLeave isDragOver } }
where
dropClass (Just _ /\ _) _ = "file-dropped"
dropClass _ (true /\ _) = "file-dropped"
dropClass (Nothing /\ _) _ = ""
dropHandler (_ /\ setDroppedFile) e = do
-- prevent redirection when file is dropped
E.preventDefault e
E.stopPropagation e
blob <- R2.dataTransferFileBlob e
void $ launchAff do
contents <- readAsText blob
liftEffect $ setDroppedFile
$ const
$ Just
$ DroppedFile { contents: (UploadFileContents contents)
, fileType: Just CSV
, lang: Just EN
}
onDragOverHandler (_ /\ setIsDragOver) e = do
-- prevent redirection when file is dropped
-- https://stackoverflow.com/a/6756680/941471
E.preventDefault e
E.stopPropagation e
setIsDragOver $ const true
onDragLeave (_ /\ setIsDragOver) _ = setIsDragOver $ const false
{-
fldr nt open = if open
then "fa fa-globe" -- <> color nt
else "fa fa-folder-globe" -- <> color nt
--else "glyphicon glyphicon-folder-close" <> color nt
where
color GT.NodeUser = ""
color FolderPublic = ""
color FolderShared = " text-warning"
color _ = " text-danger"
-}
-- 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 =
( id :: ID
, nodeType :: GT.NodeType
, refreshTree :: Unit -> Aff Unit
, session :: Session
)
nodeActions :: Record NodeActionsProps -> R.Element
nodeActions p = R.createElement nodeActionsCpt p []
nodeActionsCpt :: R.Component NodeActionsProps
nodeActionsCpt = R.hooksComponent "G.C.F.T.N.B.nodeActions" cpt
where
cpt { id, nodeType: GT.Graph, refreshTree, session } _ = do
useLoader id (graphVersions session) $ \gv ->
nodeActionsGraph { id, graphVersions: gv, session, triggerRefresh: triggerRefresh refreshTree }
cpt { id, nodeType: GT.NodeList, refreshTree, session } _ = do
useLoader { nodeId: id, session } loadCorpusWithChild $
\{ corpusId } ->
nodeActionsNodeList { listId: id
, nodeId: corpusId
, nodeType: GT.TabNgramType GT.CTabTerms
, session
, triggerRefresh: triggerRefresh refreshTree }
cpt _ _ = do
pure $ H.div {} []
graphVersions session graphId = GraphAPI.graphVersions { graphId, session }
triggerRefresh refreshTree = refreshTree
type NodeActionsGraphProps =
( id :: ID
, graphVersions :: Record GraphAPI.GraphVersions
, session :: Session
, triggerRefresh :: Unit -> Aff Unit
)
nodeActionsGraph :: Record NodeActionsGraphProps -> R.Element
nodeActionsGraph p = R.createElement nodeActionsGraphCpt p []
nodeActionsGraphCpt :: R.Component NodeActionsGraphProps
nodeActionsGraphCpt = R.hooksComponent "G.C.F.T.N.B.nodeActionsGraph" cpt
where
cpt { id, graphVersions, session, triggerRefresh } _ = do
pure $ H.div { className: "node-actions" } [
if graphVersions.gv_graph == Just graphVersions.gv_repo then
H.div {} []
else
graphUpdateButton { id, session, triggerRefresh }
]
type GraphUpdateButtonProps =
( id :: ID
, session :: Session
, triggerRefresh :: Unit -> Aff Unit
)
graphUpdateButton :: Record GraphUpdateButtonProps -> R.Element
graphUpdateButton p = R.createElement graphUpdateButtonCpt p []
graphUpdateButtonCpt :: R.Component GraphUpdateButtonProps
graphUpdateButtonCpt = R.hooksComponent "G.C.F.T.N.B.graphUpdateButton" cpt
where
cpt { id, session, triggerRefresh } _ = do
enabled <- R.useState' true
pure $ H.div { className: "update-button " <> if (fst enabled) then "enabled" else "disabled text-muted" } [
H.span { className: "fa fa-refresh"
, on: { click: onClick enabled } } []
]
where
onClick (false /\ _) _ = pure unit
onClick (true /\ setEnabled) _ = do
launchAff_ $ do
liftEffect $ setEnabled $ const false
g <- GraphAPI.updateGraphVersions { graphId: id, session }
liftEffect $ setEnabled $ const true
triggerRefresh unit
pure unit
type NodeActionsNodeListProps =
(
listId :: GT.ListId
, nodeId :: ID
, nodeType :: GT.TabSubType GT.CTabNgramType
, session :: Session
, triggerRefresh :: Unit -> Aff Unit
)
nodeActionsNodeList :: Record NodeActionsNodeListProps -> R.Element
nodeActionsNodeList p = R.createElement nodeActionsNodeListCpt p []
nodeActionsNodeListCpt :: R.Component NodeActionsNodeListProps
nodeActionsNodeListCpt = R.hooksComponent "G.C.F.T.N.B.nodeActionsNodeList" cpt
where
cpt props _ = do
pure $ H.div { className: "node-actions" } [
nodeListUpdateButton props
]
type NodeListUpdateButtonProps =
( listId :: GT.ListId
, nodeId :: ID
, nodeType :: GT.TabSubType GT.CTabNgramType
, session :: Session
, triggerRefresh :: Unit -> Aff Unit
)
nodeListUpdateButton :: Record NodeListUpdateButtonProps -> R.Element
nodeListUpdateButton p = R.createElement nodeListUpdateButtonCpt p []
nodeListUpdateButtonCpt :: R.Component NodeListUpdateButtonProps
nodeListUpdateButtonCpt = R.hooksComponent "G.C.F.T.N.B.nodeListUpdateButton" cpt
where
cpt { listId, nodeId, nodeType, session, triggerRefresh } _ = do
enabled <- R.useState' true
pure $ H.div { className: "update-button "
<> if (fst enabled) then "enabled" else "disabled text-muted"
} [ H.span { className: "fa fa-refresh"
, on: { click: onClick enabled } } []
]
where
onClick (false /\ _) _ = pure unit
onClick (true /\ setEnabled) _ = do
launchAff_ $ do
liftEffect $ setEnabled $ const false
_ <- NTAPI.updateNodeList { listId, nodeId, nodeType, session }
liftEffect $ setEnabled $ const true
triggerRefresh unit
pure unit
-- END nodeActions
mAppRouteId :: Maybe Routes.AppRoute -> Maybe Int
mAppRouteId (Just (Routes.Folder _ id)) = Just id
mAppRouteId (Just (Routes.FolderPrivate _ id)) = Just id
mAppRouteId (Just (Routes.FolderPublic _ id)) = Just id
mAppRouteId (Just (Routes.FolderShared _ id)) = Just id
mAppRouteId (Just (Routes.Team _ id)) = Just id
mAppRouteId (Just (Routes.Corpus _ id)) = Just id
mAppRouteId (Just (Routes.PGraphExplorer _ id)) = Just id
mAppRouteId (Just (Routes.Dashboard _ id)) = Just id
mAppRouteId (Just (Routes.Texts _ id)) = Just id
mAppRouteId (Just (Routes.Lists _ id)) = Just id
mAppRouteId (Just (Routes.Annuaire _ id)) = Just id
mAppRouteId (Just (Routes.UserPage _ id)) = Just id
mAppRouteId (Just (Routes.Document _ id _ )) = Just id
mAppRouteId (Just (Routes.ContactPage _ id _ )) = Just id
mAppRouteId (Just (Routes.CorpusDocument _ id _ _)) = Just id
mAppRouteId _ = Nothing
-- | START Popup View
type NodePopupProps =
( id :: ID
, name :: Name
, nodeType :: GT.NodeType
, onPopoverClose :: DOM.Element -> Effect Unit
| CommonProps
)
type NodePopupS =
( action :: Maybe NodeAction
, id :: ID
, name :: Name
, nodeType :: GT.NodeType
)
iconAStyle :: { color :: String
, paddingTop :: String
......@@ -402,52 +56,65 @@ nodePopupCpt :: R.Component NodePopupProps
nodePopupCpt = R.hooksComponent "G.C.F.T.N.B.nodePopupView" cpt
where
cpt p _ = do
renameBoxOpen <- R.useState' false
iframeRef <- R.useRef null
nodePopupState@(nodePopup /\ setNodePopup) <- R.useState' {action: Nothing, id: p.id, name: p.name, nodeType: p.nodeType}
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 }
pure $ H.div tooltipProps $
[ H.div { className: "popup-container" }
[ H.div { className: "panel panel-default" }
[ H.div {className: ""}
[ H.div { className : "col-md-10 flex-between"}
[ H.h3 { className: GT.fldr p.nodeType true} [H.text $ show p.nodeType]
-- , H.div { className : "col-md-1" } []
[ H.h3 { className: GT.fldr p.nodeType true} []
-- TODO fix names
, H.text $ S.replace (S.Pattern "Node") (S.Replacement " ")
$ S.replace (S.Pattern "Folder") (S.Replacement " ")
$ show p.nodeType
, H.p {className: "text-primary center"} [H.text p.name]
]
]
, panelHeading renameBoxOpen p
, panelHeading isOpen p
, panelBody nodePopupState p
, mPanelAction nodePopupState p search
, mPanelAction nodePopupState p
]
, if nodePopup.action == Just SearchBox then
H.div {} [ searchIframes p search iframeRef ]
else
H.div {} []
]
]
where
tooltipProps = { className : ""
, id : "node-popup-tooltip"
, title : "Node settings"
, data: { toggle: "tooltip"
, placement: "right"}
, data: { toggle : "tooltip"
, placement: "right"
}
--, style: { top: y - 65.0, left: x + 10.0 }
}
panelHeading renameBoxOpen@(open /\ _) {dispatch, id, name, nodeType} =
panelHeading isOpen@(open /\ _) {dispatch, id, name, nodeType} =
H.div {className: "panel-heading"}
[ R2.row
[ H.div {className: "col-md-8"}
[ renameBox { dispatch, id, name, nodeType, renameBoxOpen } ]
[ H.div {className: "col-md-8 flex-end"}
[ textInputBox { boxAction: renameAction
, boxName: "Rename"
, dispatch
, id
, text:name
, isOpen
}
]
, H.div {className: "flex-end"}
[ if edit then editIcon renameBoxOpen else H.div {} []
[ if edit then editIcon isOpen else H.div {} []
, H.div {className: "col-md-1"}
[ H.a { "type" : "button"
, className: glyphicon "remove-circle"
, on: { click: \e -> p.onPopoverClose $ R2.unsafeEventTarget e }
, title : "Close"} []
, className: glyphicon "window-close"
, on : { click: \e -> p.onPopoverClose
$ R2.unsafeEventTarget e
}
, title : "Close"
} []
]
]
]
......@@ -456,12 +123,12 @@ nodePopupCpt = R.hooksComponent "G.C.F.T.N.B.nodePopupView" cpt
SettingsBox {edit, doc, buttons} = settingsBox nodeType
editIcon :: R.State Boolean -> R.Element
editIcon (false /\ setRenameBoxOpen) =
editIcon (false /\ setIsOpen) =
H.div {className : "col-md-1"}
[ H.a { className: glyphicon "pencil"
, id : "rename1"
, title : "Rename"
, on: { click: \_ -> setRenameBoxOpen $ const true }
, on: { click: \_ -> setIsOpen $ const true }
}
[]
]
......@@ -472,27 +139,37 @@ nodePopupCpt = R.hooksComponent "G.C.F.T.N.B.nodePopupView" cpt
-> R.Element
panelBody nodePopupState {dispatch: d, nodeType} =
H.div {className: "panel-body flex-space-between"}
[ H.div {className: "flex-center"} [buttonClick {action: doc, state: nodePopupState}]
, H.div {className: "flex-center"}
$ map (\t -> buttonClick {action: t, state: nodePopupState}) buttons
]
$ [ H.p { "style": {"margin":"10px"}} []
, H.div { className: "flex-center"}
[ buttonClick { action: doc
, state: nodePopupState
}
]
, H.div {className: "flex-center"}
$ map (\t -> buttonClick { action: t
, state : nodePopupState
}
) buttons
]
-- FIXME trick to increase the size of the box
<> if A.length buttons < 2
then [H.div {className: "col-md-4"} []]
else []
where
SettingsBox {edit, doc, buttons} = settingsBox nodeType
mPanelAction :: R.State (Record NodePopupS)
-> Record NodePopupProps
-> R.State Search
-> R.Element
mPanelAction ({action: Nothing} /\ _) _ _ = H.div {} []
mPanelAction ({action: Just action} /\ _) p search =
mPanelAction ({action: Nothing } /\ _) _ = H.div {} []
mPanelAction ({action: Just action} /\ _) props =
panelAction { action
, dispatch : p.dispatch
, id : p.id
, name : p.name
, dispatch : props.dispatch
, id : props.id
, name : props.name
, nodePopup: Just NodePopup
, nodeType : p.nodeType
, search
, session : p.session
, nodeType : props.nodeType
, session : props.session
}
type ActionState =
......@@ -515,17 +192,17 @@ buttonClickCpt = R.hooksComponent "G.C.F.T.N.B.buttonClick" cpt
where
cpt {action: todo, state: (node@{action} /\ setNodePopup)} _ = do
pure $ H.div {className: "col-md-1"}
[ H.a { style: iconAStyle
, className: glyphiconActive (glyphiconNodeAction todo)
(action == (Just todo) )
, id: show todo
, title: show todo
, onClick : mkEffectFn1
$ \_ -> setNodePopup
$ const (node { action = action' })
}
[]
]
[ H.a { style: iconAStyle
, className: glyphiconActive (glyphiconNodeAction todo)
(action == (Just todo) )
, id: show todo
, title: show todo
, onClick : mkEffectFn1
$ \_ -> setNodePopup
$ const (node { action = action' })
}
[]
]
where
action' = if action == (Just todo)
then Nothing
......@@ -540,14 +217,13 @@ type NodeProps =
type PanelActionProps =
( id :: ID
, action :: NodeAction
, dispatch :: Action -> Aff Unit
, name :: Name
( id :: ID
, action :: NodeAction
, dispatch :: Action -> Aff Unit
, name :: Name
, nodePopup :: Maybe NodePopup
, nodeType :: GT.NodeType
, session :: Session
, search :: R.State Search
, nodeType :: GT.NodeType
, session :: Session
)
panelAction :: Record PanelActionProps -> R.Element
......@@ -564,8 +240,7 @@ panelActionCpt = R.hooksComponent "G.C.F.T.N.B.panelAction" cpt
cpt {action: Add xs, dispatch, id, name, nodePopup: p, nodeType} _ = do
pure $ addNodeView {dispatch, id, name, nodeType, nodeTypes: xs}
cpt {action: Refresh , dispatch, id, nodeType, session} _ = do
pure $ fragmentPT $ "Update " <> show nodeType
cpt {action: Refresh , dispatch, id, nodeType, session} _ = update nodeType dispatch
cpt {action: Config , dispatch, id, nodeType, session} _ = do
pure $ fragmentPT $ "Config " <> show nodeType
......@@ -577,220 +252,19 @@ panelActionCpt = R.hooksComponent "G.C.F.T.N.B.panelAction" cpt
<> "to link the corpus with your Annuaire"
<> " (and reciprocally)."
cpt props@{action: SearchBox, search, session, dispatch, nodePopup} _ =
actionSearch search session dispatch nodePopup
cpt {action : Share, dispatch, id, name } _ = do
isOpen <- R.useState' true
pure $ H.div {} [ textInputBox { boxAction: Share.shareAction
, boxName: "Share"
, dispatch
, id
, text: "username"
, isOpen
} ]
cpt props@{action: SearchBox, id, session, dispatch, nodePopup} _ =
actionSearch session (Just id) dispatch nodePopup
cpt _ _ = do
pure $ H.div {} []
-- | Action : Search
actionSearch :: R.State Search
-> Session
-> (Action -> Aff Unit)
-> Maybe NodePopup
-> R.Hooks R.Element
actionSearch search session dispatch nodePopup =
pure $ R.fragment [ H.p {"style": {"margin" :"10px"}}
[ H.text $ "Search and create a private "
<> "corpus with the search query as corpus name." ]
, searchBar { langs: allLangs
, onSearch: searchOn dispatch nodePopup
, search
, session
}
]
where
searchOn :: (Action -> Aff Unit)
-> Maybe NodePopup
-> GT.AsyncTaskWithType
-> Effect Unit
searchOn dispatch p task = do
_ <- launchAff $ dispatch (SearchQuery task)
-- close popup
-- TODO
--snd p $ const Nothing
pure unit
-- | Action : Delete
actionDelete :: NodeType -> (Action -> Aff Unit) -> R.Hooks R.Element
actionDelete NodeUser _ = do
pure $ R.fragment [
H.div {style: {margin: "10px"}}
[H.text $ "Yes, we are RGPD compliant!"
<> " But you can not delete User Node yet."
<> " We are still on development."
<> " Thanks for your comprehensin."
]
]
actionDelete _ dispatch = do
pure $ R.fragment [
H.div {style: {margin: "10px"}}
(map (\t -> H.p {} [H.text t])
[ "Are your sure you want to delete it ?"
, "If yes, click again below."
]
)
, reallyDelete dispatch
]
where
reallyDelete :: (Action -> Aff Unit) -> R.Element
reallyDelete d = H.div {className: "panel-footer"}
[ H.a { type: "button"
, className: "btn glyphicon glyphicon-trash"
, id: "delete"
, title: "Delete"
, on: {click: \_ -> launchAff $ d $ DeleteNode}
}
[H.text " Yes, delete!"]
]
-- | Action : Upload
actionUpload :: NodeType -> ID -> Session -> (Action -> Aff Unit) -> R.Hooks R.Element
actionUpload NodeList id session dispatch =
pure $ uploadTermListView {dispatch, id, nodeType: GT.NodeList, session}
actionUpload Corpus id session dispatch =
pure $ uploadFileView {dispatch, id, nodeType: Corpus, session}
actionUpload _ _ _ _ =
pure $ fragmentPT $ "Soon, upload for this NodeType."
-- | Action : Download
actionDownload :: NodeType -> ID -> Session -> R.Hooks R.Element
actionDownload NodeList id session = downloadButton href label info
where
href = url session $ Routes.NodeAPI GT.NodeList (Just id) ""
label = "Download List"
info = "Info about the List as JSON format"
actionDownload GT.Graph id session = downloadButton href label info
where
href = url session $ Routes.NodeAPI GT.Graph (Just id) "gexf"
label = "Download Graph"
info = "Info about the Graph as GEXF format"
actionDownload GT.Corpus id session = downloadButton href label info
where
href = url session $ Routes.NodeAPI GT.Corpus (Just id) "export"
label = "Download Corpus"
info = "TODO: fix the backend route"
actionDownload GT.Texts id session = downloadButton href label info
where
href = url session $ Routes.NodeAPI GT.Texts (Just id) ""
label = "Download texts"
info = "TODO: fix the backend route. What is the expected result ?"
actionDownload _ _ _ = pure $ fragmentPT $ "Soon, you will be able to dowload your file here "
type Href = String
type Label = String
type Info = String
downloadButton :: Href -> Label -> Info -> R.Hooks R.Element
downloadButton href label info = do
pure $ R.fragment [ H.div { className: "row"}
[ H.div { className: "col-md-2"} []
, H.div { className: "col-md-7 flex-center"}
[ H.p {} [H.text info] ]
]
, H.span { className: "row" }
[ H.div { className: "panel-footer"}
[ H.div { className: "col-md-3"} []
, H.div { className: "col-md-3 flex-center"}
[ H.a { className: "btn btn-default"
, href
, target: "_blank" }
[ H.text label ]
]
]
]
]
-- | Action: Show Documentation
actionDoc :: NodeType -> R.Hooks R.Element
actionDoc nodeType =
pure $ R.fragment [ H.div { style: {margin: "10px"} }
$ [ infoTitle nodeType ]
<> (map (\info -> H.p {} [H.text info]) $ docOf nodeType)
]
where
infoTitle :: NodeType -> R.Element
infoTitle nt = H.div { style: {margin: "10px"}}
[ H.h3 {} [H.text "Documentation about " ]
, H.h3 {className: GT.fldr nt true} [ H.text $ show nt ]
]
-- | TODO add documentation of all NodeType
docOf :: NodeType -> Array String
docOf GT.NodeUser = [ "This account is personal"
, "See the instances terms of uses."
]
docOf GT.FolderPrivate = ["This folder and its children are private only."]
docOf GT.FolderPublic = ["Soon, you will be able to build public folders to share your work with the world!"]
docOf GT.FolderShared = ["Soon, you will be able to build teams folders to share your work"]
docOf nodeType = ["More information on " <> show nodeType]
fragmentPT :: String -> R.Element
fragmentPT text = H.div {style: {margin: "10px"}} [H.text text]
--------------------
-- | Iframes
searchIframes :: Record NodePopupProps
-> R.State Search
-> R.Ref (Nullable DOM.Element)
-> R.Element
searchIframes {nodeType} search@(search' /\ _) iframeRef =
if isIsTex_Advanced search'.datafield then
H.div { className: "istex-search panel panel-default" }
[ H.h3 { className: GT.fldr nodeType true} []
, iframeWith "https://istex.gargantext.org" search iframeRef
]
else
if Just Web == search'.datafield then
H.div { className: "istex-search panel panel-default" }
[ H.h3 { className: GT.fldr nodeType true} []
, iframeWith "https://searx.gargantext.org" search iframeRef
]
else
H.div {} []
iframeWith :: String
-> R.State Search
-> R.Ref (Nullable DOM.Element)
-> R.Element
iframeWith url (search /\ setSearch) iframeRef =
H.iframe { src: isTexTermUrl search.term
,width: "100%"
,height: "100%"
,ref: iframeRef
,on: {
load: \_ -> do
addEventListener window "message" (changeSearchOnMessage url)
R2.postMessage iframeRef search.term
}
} []
where
changeSearchOnMessage :: String -> Callback MessageEvent
changeSearchOnMessage url =
callback $ \m -> if R2.getMessageOrigin m == url
then do
let {url, term} = R2.getMessageData m
setSearch $ _ {url = url, term = term}
else
pure unit
isTexTermUrl term = url <> query
where
query = Query.print $ NQP.print identity identity qp
qp = NQP.QueryPairs [
Tuple (NQP.keyFromString "query") (Just (NQP.valueFromString term))
]
src/Gargantext/Components/Forest/Tree/Node/Box/Types.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Box.Types where
import DOM.Simple as DOM
import Data.Maybe (Maybe)
import Effect (Effect)
import Effect.Aff (Aff)
import Gargantext.Components.Forest.Tree.Node.Settings (NodeAction)
import Gargantext.Components.Forest.Tree.Node.Action (Action)
import Gargantext.Prelude (Unit)
import Gargantext.Sessions (Session)
import Gargantext.Types (ID, Name)
import Gargantext.Types as GT
type CommonProps =
( dispatch :: Action -> Aff Unit
, session :: Session
)
type NodePopupProps =
( id :: ID
, name :: Name
, nodeType :: GT.NodeType
, onPopoverClose :: DOM.Element -> Effect Unit
| CommonProps
)
type NodePopupS =
( action :: Maybe NodeAction
, id :: ID
, name :: Name
, nodeType :: GT.NodeType
)
src/Gargantext/Components/Forest/Tree/Node/Settings.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Settings where
import Prelude (class Eq, class Show, show, (&&), (<>), (==))
import Data.Array (foldl)
import Gargantext.Types
------------------------------------------------------------------------
------------------------------------------------------------------------
{-
-- | RIGHT Management
if user has access to node then he can do all his related actions
-}
------------------------------------------------------------------------
------------------------------------------------------------------------
data Status a = IsBeta a | IsProd a
data NodeAction = Documentation NodeType
| SearchBox
| Download | Upload | Refresh | Config
| Move | Clone | Delete
| Share | Link NodeType
| Add (Array NodeType)
| CopyFromCorpus
instance eqNodeAction :: Eq NodeAction where
eq (Documentation x) (Documentation y) = true && (x == y)
eq SearchBox SearchBox = true
eq Download Download = true
eq Upload Upload = true
eq Refresh Refresh = true
eq Move Move = true
eq Clone Clone = true
eq Delete Delete = true
eq Share Share = true
eq (Link x) (Link y) = (x == y)
eq (Add x) (Add y) = (x == y)
eq CopyFromCorpus CopyFromCorpus = true
eq Config Config = true
eq _ _ = false
instance showNodeAction :: Show NodeAction where
show (Documentation x) = "Documentation of " <> show x
show SearchBox = "SearchBox"
show Download = "Download"
show Upload = "Upload"
show Refresh = "Refresh"
show Move = "Move"
show Clone = "Clone"
show Delete = "Delete"
show Share = "Share"
show Config = "Config"
show (Link x) = "Link to " <> show x
show (Add xs) = foldl (\a b -> a <> show b) "Add " xs
show CopyFromCorpus = "Copy from corpus"
glyphiconNodeAction :: NodeAction -> String
glyphiconNodeAction (Documentation _) = "question-circle"
glyphiconNodeAction Delete = "trash"
glyphiconNodeAction (Add _) = "plus"
glyphiconNodeAction SearchBox = "search"
glyphiconNodeAction Upload = "upload"
glyphiconNodeAction (Link _) = "arrows-h"
glyphiconNodeAction Download = "download"
glyphiconNodeAction CopyFromCorpus = "random"
glyphiconNodeAction Refresh = "refresh"
glyphiconNodeAction Config = "wrench"
glyphiconNodeAction Share = "user-plus"
glyphiconNodeAction Move = "share-square-o"
glyphiconNodeAction _ = ""
------------------------------------------------------------------------
data SettingsBox =
SettingsBox { show :: Boolean
, edit :: Boolean
, doc :: NodeAction
, buttons :: Array NodeAction
}
------------------------------------------------------------------------
settingsBox :: NodeType -> SettingsBox
settingsBox NodeUser =
SettingsBox { show : true
, edit : false
, doc : Documentation NodeUser
, buttons : [ Delete ]
}
settingsBox FolderPrivate =
SettingsBox { show : true
, edit : false
, doc : Documentation FolderPrivate
, buttons : [ Add [ Corpus
, Folder
, Annuaire
]
]
}
settingsBox Team =
SettingsBox { show : true
, edit : true
, doc : Documentation Team
, buttons : [ Add [ Corpus
, Folder
, Annuaire
]
, Share
, Delete]
}
settingsBox FolderShared =
SettingsBox { show : true
, edit : true
, doc : Documentation FolderShared
, buttons : [ Add [Team, FolderShared]
-- , Delete
]
}
settingsBox FolderPublic =
SettingsBox { show : true
, edit : false
, doc : Documentation FolderPublic
, buttons : [ Add [ Corpus
, Folder
]
]
}
settingsBox Folder =
SettingsBox { show : true
, edit : true
, doc : Documentation Folder
, buttons : [ Add [ Corpus
, Folder
, Annuaire
]
, Move
, Delete
]
}
settingsBox Corpus =
SettingsBox { show : true
, edit : true
, doc : Documentation Corpus
, buttons : [ Add [ NodeList
, Graph
, Dashboard
]
, SearchBox
, Upload
, Download
, Move
--, Clone
, Link Annuaire
, Delete
]
}
settingsBox Texts =
SettingsBox { show : true
, edit : false
, doc : Documentation Texts
, buttons : [ Refresh
, Upload
, Download
-- , Delete
]
}
settingsBox Graph =
SettingsBox { show : true
, edit : false
, doc : Documentation Graph
, buttons : [ Refresh
, Config
, Download -- TODO as GEXF or JSON
, Delete
]
}
settingsBox NodeList =
SettingsBox { show : true
, edit : false
, doc : Documentation NodeList
, buttons : [ Refresh
, Config
, Download
, Upload
, CopyFromCorpus
, Delete
]
}
settingsBox Dashboard =
SettingsBox { show : true
, edit : false
, doc : Documentation Dashboard
, buttons : [ Refresh
, Delete
]
}
settingsBox Annuaire =
SettingsBox { show : true
, edit : false
, doc : Documentation Annuaire
, buttons : [ Upload
, Move
, Delete
]
}
settingsBox _ =
SettingsBox { show : false
, edit : false
, doc : Documentation NodeUser
, buttons : []
}
src/Gargantext/Components/Forest/Tree/Node/Tools.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Tools
where
import Data.Maybe (fromMaybe)
import Data.String as S
import Data.Tuple.Nested ((/\))
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.Types (ID)
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Reactix.DOM.HTML as H
------------------------------------------------------------------------
type Body = Array R.Element
type Footer = R.Element
panel :: Body -> Footer -> R.Element
panel bodies submit =
H.div {} [ panelBody bodies, footer submit ]
where
panelBody bs =
H.div {className: "panel-body"}
[ H.div { className: "row"
, style: {"margin":"10px"}
}
[ H.div { className: "col-md-10" }
-- TODO add type for text or form here
[ H.form {className: "form-horizontal"} bs
]
]
]
footer sb =
H.div {className: "panel-footer"}
[ H.div {} []
, H.div { className: "center"} [ sb ]
]
------------------------------------------------------------------------
-- | START Text input
type TextInputBoxProps =
( id :: ID
, dispatch :: Action -> Aff Unit
, text :: String
, isOpen :: R.State Boolean
, boxName :: String
, boxAction :: String -> Action
)
textInputBox :: Record TextInputBoxProps -> R.Element
textInputBox p@{ boxName, boxAction, dispatch, isOpen: (true /\ setIsOpen) } = R.createElement el p []
where
el = R.hooksComponent (boxName <> "Box") cpt
cpt {id, text} _ = do
renameNodeName <- R.useState' text
pure $ H.div {className: "from-group row-no-padding"}
[ textInput renameNodeName
, submitBtn renameNodeName
, cancelBtn
]
where
textInput (_ /\ setRenameNodeName) =
H.div {className: "col-md-8"}
[ H.input { type: "text"
, placeholder: (boxName <> " Node")
, defaultValue: text
, className: "form-control"
, onInput: mkEffectFn1 $ setRenameNodeName
<<< const
<<< R2.unsafeEventValue
}
]
submitBtn (newName /\ _) =
H.a {className: "btn glyphitem glyphicon glyphicon-ok col-md-2 pull-left"
, type: "button"
, onClick: mkEffectFn1 $ \_ -> do
setIsOpen $ const false
launchAff $ dispatch ( boxAction newName )
, title: "Submit"
} []
cancelBtn =
H.a {className: "btn text-danger glyphitem glyphicon glyphicon-remove col-md-2 pull-left"
, type: "button"
, onClick: mkEffectFn1 $ \_ -> setIsOpen $ const false
, title: "Cancel"
} []
textInputBox p@{ boxName, isOpen: (false /\ _) } = R.createElement el p []
where
el = R.hooksComponent (boxName <> "Box") cpt
cpt {text} _ = pure $ H.div {} []
-- | END Rename Box
-- | Sugar Text style
fragmentPT :: String -> R.Element
fragmentPT text = H.div {style: {margin: "10px"}} [H.text text]
-- | Form Edit input
type DefaultText = String
formEdit :: forall previous next
. DefaultText
-> ((previous -> String)
-> Effect next)
-> R.Element
formEdit defaultValue setter =
H.div {className: "form-group"}
[ H.input { type : "text"
, placeholder : defaultValue
, defaultValue: "Write" <> defaultValue
, className : "form-control"
, onInput : mkEffectFn1
$ setter
<<< const
<<< R2.unsafeEventValue
}
]
-- | Form Choice input
-- if the list of options is not big enough, a button is used instead
formChoiceSafe :: forall a b c
. Read a
=> Show a
=> Array a
-> a
-> ((b -> a) -> Effect c)
-> R.Element
formChoiceSafe [] _ _ = H.div {} []
formChoiceSafe [n] _defaultNodeType setNodeType =
formButton n setNodeType
formChoiceSafe nodeTypes defaultNodeType setNodeType =
formChoice nodeTypes defaultNodeType setNodeType
-- | List Form
formChoice :: forall a b c d
. Read b
=> Show d
=> Array d
-> b
-> ((c -> b) -> Effect a)
-> R.Element
formChoice nodeTypes defaultNodeType setNodeType =
H.div { className: "form-group"}
[ R2.select { className: "form-control"
, onChange : mkEffectFn1
$ setNodeType
<<< const
<<< fromMaybe defaultNodeType
<<< read
<<< R2.unsafeEventValue
}
(map (\opt -> H.option {} [ H.text $ show opt ]) nodeTypes)
]
-- | Button Form
-- FIXME: currently needs a click from the user (by default, we could avoid such click)
formButton :: forall a b c
. a
-> ((b -> a) -> Effect c)
-> R.Element
formButton nodeType setNodeType =
H.button { className : "btn btn-primary center"
, type : "button"
, title: "Form Button"
, style : { width: "50%" }
, onClick : mkEffectFn1
$ \_ -> setNodeType ( const nodeType )
} [H.text $ "Go !"]
------------------------------------------------------------------------
------------------------------------------------------------------------
submitButton :: Action -> (Action -> Aff Unit) -> R.Element
submitButton action dispatch =
H.button { className : "btn btn-primary fa fa-" <> icon action
, type: "button"
, style : { width: "50%" }
, id: S.toLower $ show action
, title: show action
, on: {click: \_ -> launchAff $ dispatch action}
}
[ H.text $ " " <> text action]
type Href = String
submitButtonHref :: Action -> Href -> R.Element
submitButtonHref action href =
H.a { className : "btn btn-primary fa fa-" <> icon action
, style : { width: "50%" }
, href
, target: "_blank"
}
[ H.text $ " " <> text action]
src/Gargantext/Components/Forest/Tree/Node/FTree.purs → src/Gargantext/Components/Forest/Tree/Node/Tools/FTree.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.FTree where
module Gargantext.Components.Forest.Tree.Node.Tools.FTree where
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, jsonEmptyObject, (.:), (:=), (~>))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..))
import Data.Argonaut (class DecodeJson, decodeJson, (.:))
import Data.Newtype (class Newtype)
import Effect.Aff (Aff)
import Prelude hiding (div)
import Gargantext.Components.Lang (Lang)
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, get, put, post, delete)
import Gargantext.Routes as GR
import Gargantext.Types as GT
import Prelude hiding (div)
-----------------------------------------------------------------------
type ID = Int
......
src/Gargantext/Components/Forest/Tree/Node/ProgressBar.purs → src/Gargantext/Components/Forest/Tree/Node/Tools/ProgressBar.purs
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.ProgressBar where
module Gargantext.Components.Forest.Tree.Node.Tools.ProgressBar where
import Gargantext.Prelude
......@@ -20,10 +20,8 @@ import Reactix.DOM.HTML as H
data BarType = Bar | Pie
type Props =
(
asyncTask :: GT.AsyncTaskWithType
( asyncTask :: GT.AsyncTaskWithType
, barType :: BarType
, corpusId :: GT.ID
, onFinish :: Unit -> Effect Unit
......@@ -37,7 +35,11 @@ asyncProgressBar p = R.createElement asyncProgressBarCpt p []
asyncProgressBarCpt :: R.Component Props
asyncProgressBarCpt = R.hooksComponent "G.C.F.T.N.PB.asyncProgressBar" cpt
where
cpt props@{asyncTask: (GT.AsyncTaskWithType {task: GT.AsyncTask {id}}), barType, corpusId, onFinish} _ = do
cpt props@{ asyncTask: (GT.AsyncTaskWithType {task: GT.AsyncTask {id}})
, barType
, corpusId
, onFinish
} _ = do
(progress /\ setProgress) <- R.useState' 0.0
intervalIdRef <- R.useRef Nothing
......@@ -66,9 +68,8 @@ asyncProgressBarCpt = R.hooksComponent "G.C.F.T.N.PB.asyncProgressBar" cpt
toInt n = unsafePartial $ fromJust $ fromNumber n
type ProgressIndicatorProps =
(
barType :: BarType
, label :: String
( barType :: BarType
, label :: String
, progress :: Int
)
......@@ -97,7 +98,14 @@ progressIndicatorCpt = R.hooksComponent "G.C.F.T.N.PB.progressIndicator" cpt
]
queryProgress :: Record Props -> Aff GT.AsyncProgress
queryProgress {asyncTask: GT.AsyncTaskWithType {task: GT.AsyncTask {id}, typ}, corpusId, session} = get session p
queryProgress { asyncTask: GT.AsyncTaskWithType { task: GT.AsyncTask {id}
, typ
}
, corpusId
, session
} = get session (p typ)
where
p = NodeAPI GT.Corpus (Just corpusId) $ path <> id <> "/poll?limit=1"
-- TODO refactor path
p GT.UpdateNode = NodeAPI GT.Node (Just corpusId) $ path <> id <> "/poll?limit=1"
p _ = NodeAPI GT.Corpus (Just corpusId) $ path <> id <> "/poll?limit=1"
path = GT.asyncTaskTypePath typ
src/Gargantext/Components/Forest/Tree/Node/Tools/Sync.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Tools.Sync where
import Effect.Aff (Aff, launchAff_)
import Data.Tuple.Nested ((/\))
import Data.Maybe (Maybe(..))
import Effect.Class (liftEffect)
import Data.Tuple (fst)
import Reactix.DOM.HTML as H
import Reactix as R
import Gargantext.Components.GraphExplorer.API as GraphAPI
import Gargantext.Components.NgramsTable.API as NTAPI
import Gargantext.Prelude (Unit, bind, const, discard, pure, unit, ($), (<>), (==))
import Gargantext.Types as GT
import Gargantext.Sessions (Session)
-- | Sync Node (Graph)
type NodeActionsGraphProps =
( id :: GT.ID
, graphVersions :: Record GraphAPI.GraphVersions
, session :: Session
, triggerRefresh :: Unit -> Aff Unit
)
nodeActionsGraph :: Record NodeActionsGraphProps -> R.Element
nodeActionsGraph p = R.createElement nodeActionsGraphCpt p []
nodeActionsGraphCpt :: R.Component NodeActionsGraphProps
nodeActionsGraphCpt = R.hooksComponent "G.C.F.T.N.B.nodeActionsGraph" cpt
where
cpt { id, graphVersions, session, triggerRefresh } _ = do
pure $ H.div { className: "node-actions" } [
if graphVersions.gv_graph == Just graphVersions.gv_repo then
H.div {} []
else
graphUpdateButton { id, session, triggerRefresh }
]
type GraphUpdateButtonProps =
( id :: GT.ID
, session :: Session
, triggerRefresh :: Unit -> Aff Unit
)
graphUpdateButton :: Record GraphUpdateButtonProps -> R.Element
graphUpdateButton p = R.createElement graphUpdateButtonCpt p []
graphUpdateButtonCpt :: R.Component GraphUpdateButtonProps
graphUpdateButtonCpt = R.hooksComponent "G.C.F.T.N.B.graphUpdateButton" cpt
where
cpt { id, session, triggerRefresh } _ = do
enabled <- R.useState' true
pure $ H.div { className: "update-button "
<> if (fst enabled)
then "enabled"
else "disabled text-muted"
} [ H.span { className: "fa fa-refresh"
, on: { click: onClick enabled } } []
]
where
onClick (false /\ _) _ = pure unit
onClick (true /\ setEnabled) _ = do
launchAff_ $ do
liftEffect $ setEnabled $ const false
g <- GraphAPI.updateGraphVersions { graphId: id, session }
liftEffect $ setEnabled $ const true
triggerRefresh unit
pure unit
-- | Sync Node (List)
type NodeActionsNodeListProps =
(
listId :: GT.ListId
, nodeId :: GT.ID
, nodeType :: GT.TabSubType GT.CTabNgramType
, session :: Session
, triggerRefresh :: Unit -> Aff Unit
)
nodeActionsNodeList :: Record NodeActionsNodeListProps -> R.Element
nodeActionsNodeList p = R.createElement nodeActionsNodeListCpt p []
nodeActionsNodeListCpt :: R.Component NodeActionsNodeListProps
nodeActionsNodeListCpt = R.hooksComponent "G.C.F.T.N.B.nodeActionsNodeList" cpt
where
cpt props _ = do
pure $ H.div { className: "node-actions" } [
nodeListUpdateButton props
]
type NodeListUpdateButtonProps =
( listId :: GT.ListId
, nodeId :: GT.ID
, nodeType :: GT.TabSubType GT.CTabNgramType
, session :: Session
, triggerRefresh :: Unit -> Aff Unit
)
nodeListUpdateButton :: Record NodeListUpdateButtonProps -> R.Element
nodeListUpdateButton p = R.createElement nodeListUpdateButtonCpt p []
nodeListUpdateButtonCpt :: R.Component NodeListUpdateButtonProps
nodeListUpdateButtonCpt = R.hooksComponent "G.C.F.T.N.B.nodeListUpdateButton" cpt
where
cpt { listId, nodeId, nodeType, session, triggerRefresh } _ = do
enabled <- R.useState' true
pure $ H.div { className: "update-button "
<> if (fst enabled) then "enabled" else "disabled text-muted"
} [ H.span { className: "fa fa-refresh"
, on: { click: onClick enabled } } []
]
where
onClick (false /\ _) _ = pure unit
onClick (true /\ setEnabled) _ = do
launchAff_ $ do
liftEffect $ setEnabled $ const false
_ <- NTAPI.updateNodeList { listId, nodeId, nodeType, session }
liftEffect $ setEnabled $ const true
triggerRefresh unit
pure unit
src/Gargantext/Components/Forest/Tree/Node/Tools/Task.purs 0 → 100644
View file @ 0b03d8c1
module Gargantext.Components.Forest.Tree.Node.Tools.Task
where
import Data.Array as A
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Gargantext.AsyncTasks as GAT
import Gargantext.Prelude (Unit, discard, identity, ($), (+))
import Gargantext.Types (Reload)
import Gargantext.Types as GT
import Reactix as R
type Tasks =
( onTaskAdd :: GT.AsyncTaskWithType -> Effect Unit
, onTaskFinish :: GT.AsyncTaskWithType -> Effect Unit
, tasks :: Array GT.AsyncTaskWithType
)
tasksStruct :: Int
-> R.State GAT.Storage
-> R.State Reload
-> Record Tasks
tasksStruct id (asyncTasks /\ setAsyncTasks) (_ /\ setReload) =
{ onTaskAdd, onTaskFinish, tasks }
where
tasks = maybe [] identity $ Map.lookup id asyncTasks
onTaskAdd t = do
setReload (_ + 1)
setAsyncTasks $ Map.alter (maybe (Just [t])
$ (\ts -> Just $ A.cons t ts)) id
onTaskFinish t = do
setReload (_ + 1)
setAsyncTasks $ Map.alter (maybe Nothing $ (\ts -> Just $ GAT.removeTaskFromList ts t)) id
src/Gargantext/Components/GraphExplorer/API.purs
View file @ 0b03d8c1
module Gargantext.Components.GraphExplorer.API where
import Gargantext.Prelude
import Data.Maybe (Maybe)
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Effect.Aff (Aff)
import Gargantext.Components.GraphExplorer.Types as GET
import Gargantext.Components.NgramsTable.Core as NTC
import Gargantext.Hooks.Sigmax.Types as SigmaxT
import Gargantext.Prelude
import Gargantext.Routes as GR
import Gargantext.Sessions (Session, get, post)
import Gargantext.Types as GT
......
src/Gargantext/Components/GraphExplorer/Sidebar.purs
View file @ 0b03d8c1
......@@ -2,8 +2,6 @@ module Gargantext.Components.GraphExplorer.Sidebar
(Props, sidebar)
where
import Prelude
import Control.Parallel (parTraverse)
import Data.Array (head, last)
import Data.Int (fromString)
......@@ -16,22 +14,20 @@ import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Effect.Class (liftEffect)
import Partial.Unsafe (unsafePartial)
import Reactix as R
import Reactix.DOM.HTML as RH
import Gargantext.Components.GraphExplorer.Types as GET
import Gargantext.Components.NgramsTable.Core as NTC
import Gargantext.Components.Nodes.Corpus.Graph.Tabs (tabs) as CGT
import Gargantext.Components.RandomText (words)
import Gargantext.Data.Array (mapMaybe)
import Gargantext.Ends (Frontends, url)
import Gargantext.Ends (Frontends)
import Gargantext.Hooks.Sigmax.Types as SigmaxT
import Gargantext.Routes as Routes
import Gargantext.Sessions (Session)
import Gargantext.Types (CTabNgramType, TabSubType(..), TabType(..), TermList(..), modeTabType)
import Gargantext.Types as GT
import Gargantext.Utils.Reactix as R2
import Partial.Unsafe (unsafePartial)
import Gargantext.Prelude
import Reactix as R
import Reactix.DOM.HTML as RH
type Props =
( frontends :: Frontends
......
src/Gargantext/Components/Lang.purs
View file @ 0b03d8c1
......@@ -2,8 +2,7 @@ module Gargantext.Components.Lang where
import Data.Argonaut (class EncodeJson, encodeJson)
import Data.Maybe (Maybe(..))
import Gargantext.Prelude (class Eq, class Show, show)
import Gargantext.Prelude (class Eq, class Show, show, class Read)
-- Language used for search
allLangs :: Array Lang
......@@ -16,23 +15,23 @@ allLangs = [ EN
data Lang = FR | EN | Universal | No_extraction
instance showLang :: Show Lang where
show FR = "FR"
show EN = "EN"
show Universal = "All"
show FR = "FR"
show EN = "EN"
show Universal = "All"
show No_extraction = "Nothing"
derive instance eqLang :: Eq Lang
readLang :: String -> Maybe Lang
readLang "FR" = Just FR
readLang "EN" = Just EN
readLang "All" = Just Universal
readLang "Nothing" = Just No_extraction
readLang _ = Nothing
instance readLang :: Read Lang where
read "FR" = Just FR
read "EN" = Just EN
read "All" = Just Universal
read "Nothing" = Just No_extraction
read _ = Nothing
instance encodeJsonLang :: EncodeJson Lang where
encodeJson a = encodeJson (show a)
-- Language used for the landing page
data LandingLang = LL_EN | LL_FR
src/Gargantext/Components/Login.purs
View file @ 0b03d8c1
......@@ -63,7 +63,7 @@ modalCpt = R.hooksComponent "G.C.Login.modal" cpt where
[ H.h2 {className: "text-primary center m-a-2"}
[
-- H.i {className: "material-icons md-36"} [ H.text "control_point" ]
H.span {className: "icon-text"} [ H.text "Gargantext" ] ] ]
H.span {className: "icon-text"} [ H.text "GarganText" ] ] ]
closing = H.button { "type": "button", className: "close"
, "data": { dismiss: "modal" } }
......@@ -208,8 +208,10 @@ formCpt = R.hooksComponent "G.C.Login.form" cpt where
csrfTokenInput :: {} -> R.Element
csrfTokenInput _ =
H.input { type: "hidden", name: "csrfmiddlewaretoken"
, value: csrfMiddlewareToken }-- TODO hard-coded CSRF token
H.input { type: "hidden"
, name: "csrfmiddlewaretoken"
, value: csrfMiddlewareToken
} -- TODO hard-coded CSRF token
termsCheckbox :: R.State Boolean -> R.Element
termsCheckbox setCheckBox =
......
src/Gargantext/Components/NgramsTable.purs
View file @ 0b03d8c1
......@@ -22,24 +22,22 @@ import Data.Set as Set
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(..), fst, snd)
import Data.Tuple.Nested ((/\))
import DOM.Simple.Console (log2)
import Effect (Effect)
import Prelude (class Show, Unit, bind, const, discard, identity, map, mempty, not, pure, show, unit, (#), ($), (&&), (/=), (<$>), (<<<), (<>), (=<<), (==), (||))
import Reactix as R
import Reactix.DOM.HTML as H
import Unsafe.Coerce (unsafeCoerce)
import Gargantext.Components.AutoUpdate (autoUpdateElt)
import Gargantext.Components.Loader (loader)
import Gargantext.Components.LoadingSpinner (loadingSpinner)
import Gargantext.Components.NgramsTable.Core (Action(..), CoreState, Dispatch, NgramsElement(..), NgramsPatch(..), NgramsTable, NgramsTerm, PageParams, PatchMap(..), Versioned(..), VersionedNgramsTable, _NgramsElement, _NgramsTable, _children, _list, _ngrams, _occurrences, _root, addNewNgram, applyNgramsPatches, applyPatchSet, commitPatchR, convOrderBy, filterTermSize, fromNgramsPatches, initialPageParams, loadNgramsTableAll, ngramsTermText, normNgram, patchSetFromMap, replace, rootsOf, singletonNgramsTablePatch, syncPatchesR)
import Gargantext.Components.NgramsTable.Components as NTC
import Gargantext.Components.NgramsTable.Core (Action(..), CoreState, Dispatch, NgramsElement(..), NgramsPatch(..), NgramsTable, NgramsTerm, PageParams, PatchMap(..), Versioned(..), VersionedNgramsTable, _NgramsElement, _NgramsTable, _children, _list, _ngrams, _occurrences, _root, addNewNgram, applyNgramsPatches, applyPatchSet, commitPatchR, convOrderBy, filterTermSize, fromNgramsPatches, initialPageParams, loadNgramsTableAll, ngramsTermText, normNgram, patchSetFromMap, replace, rootsOf, singletonNgramsTablePatch, syncPatchesR)
import Gargantext.Components.Table as T
import Gargantext.Prelude (class Show, Unit, bind, const, discard, identity, map, mempty, not, pure, show, unit, (#), ($), (&&), (/=), (<$>), (<<<), (<>), (=<<), (==), (||), read)
import Gargantext.Sessions (Session)
import Gargantext.Types (CTabNgramType, OrderBy(..), SearchQuery, TabType, TermList(..), TermSize, readTermList, readTermSize, termLists, termSizes)
import Gargantext.Types (CTabNgramType, OrderBy(..), SearchQuery, TabType, TermList(..), TermSize, termLists, termSizes)
import Gargantext.Utils (queryMatchesLabel, toggleSet)
import Gargantext.Utils.List (sortWith) as L
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Reactix.DOM.HTML as H
import Unsafe.Coerce (unsafeCoerce)
type State' =
CoreState
......@@ -160,7 +158,7 @@ tableContainerCpt { dispatch
[ R2.select { id: "picklistmenu"
, className: "form-control custom-select"
, defaultValue: (maybe "" show termListFilter)
, on: {change: setTermListFilter <<< readTermList <<< R2.unsafeEventValue}}
, on: {change: setTermListFilter <<< read <<< R2.unsafeEventValue}}
(map optps1 termLists)]
]
, H.div {className: "col-md-2", style: {marginTop : "6px"}}
......@@ -168,7 +166,7 @@ tableContainerCpt { dispatch
[ R2.select {id: "picktermtype"
, className: "form-control custom-select"
, defaultValue: (maybe "" show termSizeFilter)
, on: {change: setTermSizeFilter <<< readTermSize <<< R2.unsafeEventValue}}
, on: {change: setTermSizeFilter <<< read <<< R2.unsafeEventValue}}
(map optps1 termSizes)]
]
, H.div { className: "col-md-2", style: { marginTop: "6px" } } [
......@@ -226,19 +224,27 @@ tableContainerCpt { dispatch
editor = H.div {} $ maybe [] f ngramsParent
where
f ngrams = [
H.p {} [H.text $ "Editing " <> ngramsTermText ngrams]
, NTC.renderNgramsTree { ngramsTable, ngrams, ngramsStyle: [], ngramsClick, ngramsEdit }
, H.button {className: "btn btn-primary", on: {click: (const $ dispatch AddTermChildren)}} [H.text "Save"]
, H.button {className: "btn btn-secondary", on: {click: (const $ dispatch $ SetParentResetChildren Nothing)}} [H.text "Cancel"]
]
f ngrams = [ H.p {} [H.text $ "Editing " <> ngramsTermText ngrams]
, NTC.renderNgramsTree { ngramsTable
, ngrams
, ngramsStyle: []
, ngramsClick
, ngramsEdit
}
, H.button { className: "btn btn-primary"
, on: {click: (const $ dispatch AddTermChildren)}
} [H.text "Save"]
, H.button { className: "btn btn-secondary"
, on: {click: (const $ dispatch $ SetParentResetChildren Nothing)}
} [H.text "Cancel"]
]
where
ngramsTable = ngramsTableCache # at ngrams
<<< _Just
<<< _NgramsElement
<<< _children
%~ applyPatchSet (patchSetFromMap ngramsChildren)
ngramsClick {depth: 1, ngrams: child} = Just $ dispatch $ ToggleChild true child
ngramsClick {depth: 1, ngrams: child} = Just $ dispatch $ ToggleChild false child
ngramsClick _ = Nothing
ngramsEdit _ = Nothing
......
src/Gargantext/Components/NgramsTable/API.purs
View file @ 0b03d8c1
module Gargantext.Components.NgramsTable.API where
import Gargantext.Prelude
import Data.Maybe (Maybe)
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Gargantext.Components.NgramsTable.Core as NTC
import Effect.Aff (Aff)
import Gargantext.Routes as GR
import Gargantext.Sessions (Session, get, post)
import Gargantext.Sessions (Session, post)
import Gargantext.Types as GT
type UpdateNodeListParams =
......
src/Gargantext/Components/Nodes/Corpus/Chart/Predefined.purs
View file @ 0b03d8c1
......@@ -2,19 +2,20 @@ module Gargantext.Components.Nodes.Corpus.Chart.Predefined where
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Ord (genericCompare)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe(..), fromMaybe)
import Reactix as R
import Gargantext.Prelude
import Gargantext.Prelude
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 =
......@@ -23,24 +24,29 @@ data PredefinedChart =
| CInstitutesTree
| CTermsMetrics
derive instance genericPredefinedChart :: Generic PredefinedChart _
instance showPredefinedChart :: Show PredefinedChart where
show = genericShow
derive instance eqPredefinedChart :: Eq PredefinedChart
instance ordPredefinedChart :: Ord PredefinedChart where
compare = genericCompare
instance decodePredefinedChart :: DecodeJson PredefinedChart where
decodeJson json = do
obj <- decodeJson json
pure $ readChart' obj
pure $ fromMaybe CDocsHistogram $ read obj
instance encodePredefinedChart :: EncodeJson PredefinedChart where
encodeJson c = encodeJson $ show c
readChart' :: String -> PredefinedChart
readChart' "CDocsHistogram" = CDocsHistogram
readChart' "CAuthorsPie" = CAuthorsPie
readChart' "CInstitutesTree" = CInstitutesTree
readChart' "CTermsMetrics" = CTermsMetrics
readChart' _ = CDocsHistogram
instance readPredefinedChart :: Read PredefinedChart where
read "CDocsHistogram" = Just CDocsHistogram
read "CAuthorsPie" = Just CAuthorsPie
read "CInstitutesTree" = Just CInstitutesTree
read "CTermsMetrics" = Just CTermsMetrics
read _ = Nothing
allPredefinedCharts :: Array PredefinedChart
......
src/Gargantext/Components/Nodes/Corpus/Dashboard.purs
View file @ 0b03d8c1
module Gargantext.Components.Nodes.Corpus.Dashboard where
import DOM.Simple.Console (log2)
import Data.Array as A
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (fst)
import Data.Tuple.Nested ((/\))
import DOM.Simple.Console (log2)
import Effect (Effect)
import Effect.Aff (launchAff_)
import Effect.Class (liftEffect)
import Reactix as R
import Reactix.DOM.HTML as H
import Gargantext.Prelude
import Gargantext.Components.Node (NodePoly(..))
import Gargantext.Components.Nodes.Corpus.Chart.Predefined as P
import Gargantext.Components.Nodes.Dashboard.Types as DT
import Gargantext.Hooks.Loader (useLoader)
import Gargantext.Utils.Reactix as R2
import Gargantext.Prelude
import Gargantext.Sessions (Session)
import Gargantext.Types (NodeID)
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Reactix.DOM.HTML as H
type Props =
(
nodeId :: NodeID
( nodeId :: NodeID
, session :: Session
)
......@@ -49,12 +45,11 @@ dashboardLayoutCpt = R.hooksComponent "G.C.N.C.D.dashboardLayout" cpt
where
onChange :: NodeID -> R.State Int -> DT.Hyperdata -> Array P.PredefinedChart -> Effect Unit
onChange nodeId (_ /\ setReload) (DT.Hyperdata h) charts = do
onChange nodeId' (_ /\ setReload) (DT.Hyperdata h) charts = do
launchAff_ do
DT.saveDashboard {
hyperdata: DT.Hyperdata $ h { charts = charts }
, nodeId
, session }
DT.saveDashboard { hyperdata: DT.Hyperdata $ h { charts = charts }
, nodeId:nodeId'
, session }
liftEffect $ setReload $ (+) 1
type LoadedProps =
......@@ -127,7 +122,7 @@ renderChartCpt = R.hooksComponent "G.C.N.C.D.renderChart" cpt
where
option pc =
H.option { value: show pc } [ H.text $ show pc ]
onSelectChange e = onChange $ P.readChart' value
onSelectChange e = onChange $ fromMaybe P.CDocsHistogram $ read value
where
value = R2.unsafeEventValue e
onRemoveClick _ = onRemove unit
......
src/Gargantext/Components/Nodes/Corpus/Types.purs
View file @ 0b03d8c1
module Gargantext.Components.Nodes.Corpus.Types where
import Data.Maybe (Maybe(..))
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, (.:), (.:?), (:=), (~>), jsonEmptyObject)
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, (.:), (:=), (~>), jsonEmptyObject)
import Data.List as List
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Show (genericShow)
import Data.List ((:))
import Data.List as List
import Data.Maybe (Maybe)
import Gargantext.Prelude
import Data.Maybe (Maybe(..))
import Gargantext.Components.Node (NodePoly)
import Gargantext.Components.Nodes.Corpus.Chart.Predefined as P
import Gargantext.Prelude
type Author = String
type Description = String
......@@ -25,47 +20,47 @@ type MarkdownText = String
type Hash = String
newtype Hyperdata =
Hyperdata
{
fields :: List.List FTField
}
Hyperdata { fields :: List.List FTField }
instance decodeHyperdata :: DecodeJson Hyperdata where
decodeJson json = do
obj <- decodeJson json
fields <- obj .: "fields"
pure $ Hyperdata {fields}
instance encodeHyperdata :: EncodeJson Hyperdata where
encodeJson (Hyperdata {fields}) = do
"fields" := fields
~> jsonEmptyObject
newtype Field a = Field {
name :: String
, typ :: a
}
newtype Field a =
Field { name :: String
, typ :: a
}
type FTField = Field FieldType
derive instance genericFTField :: Generic (Field FieldType) _
instance eqFTField :: Eq (Field FieldType) where
eq = genericEq
instance showFTField :: Show (Field FieldType) where
show = genericShow
data FieldType =
Haskell {
haskell :: HaskellCode
, tag :: Tag
}
| JSON {
authors :: Author
, desc :: Description
, query :: Query
, tag :: Tag
, title :: Title
}
| Markdown {
tag :: Tag
, text :: MarkdownText
}
Haskell { haskell :: HaskellCode
, tag :: Tag
}
| JSON { authors :: Author
, desc :: Description
, query :: Query
, tag :: Tag
, title :: Title
}
| Markdown { tag :: Tag
, text :: MarkdownText
}
isJSON :: FTField -> Boolean
......@@ -90,10 +85,13 @@ getCorpusInfo as = case List.head (List.filter isJSON as) of
}
derive instance genericFieldType :: Generic FieldType _
instance eqFieldType :: Eq FieldType where
eq = genericEq
instance showFieldType :: Show FieldType where
show = genericShow
instance decodeFTField :: DecodeJson (Field FieldType) where
decodeJson json = do
obj <- decodeJson json
......@@ -118,6 +116,7 @@ instance decodeFTField :: DecodeJson (Field FieldType) where
pure $ Markdown {tag, text}
_ -> Left $ "Unsupported 'type' " <> type_
pure $ Field {name, typ}
instance encodeFTField :: EncodeJson (Field FieldType) where
encodeJson (Field {name, typ}) =
"data" := typ
......@@ -128,6 +127,7 @@ instance encodeFTField :: EncodeJson (Field FieldType) where
typ' (Haskell _) = "Haskell"
typ' (JSON _) = "JSON"
typ' (Markdown _) = "Markdown"
instance encodeFieldType :: EncodeJson FieldType where
encodeJson (Haskell {haskell}) =
"haskell" := haskell
......@@ -146,42 +146,51 @@ instance encodeFieldType :: EncodeJson FieldType where
~> jsonEmptyObject
defaultHaskell :: FieldType
defaultHaskell = Haskell defaultHaskell'
defaultHaskell' = {
haskell: ""
, tag: "HaskellField"
}
defaultHaskell = Haskell defaultHaskell'
defaultHaskell' :: { haskell :: String, tag :: String }
defaultHaskell' = { haskell: ""
, tag : "HaskellField"
}
defaultJSON :: FieldType
defaultJSON = JSON defaultJSON'
defaultJSON' = {
authors: ""
, desc: ""
, query: ""
, tag: "JSONField"
, title: ""
}
defaultJSON' :: { authors :: String
, desc :: String
, query :: String
, tag :: String
, title :: String
}
defaultJSON' = { authors: ""
, desc: ""
, query: ""
, tag: "JSONField"
, title: ""
}
defaultMarkdown :: FieldType
defaultMarkdown = Markdown defaultMarkdown'
defaultMarkdown' = {
tag: "MarkdownField"
, text: "# New file"
}
defaultMarkdown' :: { tag :: String
, text :: String
}
defaultMarkdown' = { tag: "MarkdownField"
, text: "# New file"
}
defaultField :: FTField
defaultField = Field {
name: "New file"
, typ: defaultMarkdown
}
defaultField = Field { name: "New file"
, typ: defaultMarkdown
}
newtype CorpusInfo =
CorpusInfo
{ title :: String
, authors :: String
, desc :: String
, query :: String
, totalRecords :: Int }
CorpusInfo { title :: String
, authors :: String
, desc :: String
, query :: String
, totalRecords :: Int
}
instance decodeCorpusInfo :: DecodeJson CorpusInfo where
decodeJson json = do
......
src/Gargantext/Components/Nodes/Dashboard/Types.purs
View file @ 0b03d8c1
module Gargantext.Components.Nodes.Dashboard.Types where
import Data.Maybe (Maybe(..))
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, (.:), (.:?), (:=), (~>), jsonEmptyObject)
import Data.Maybe (Maybe)
import Data.Maybe (Maybe(..))
import Effect.Aff (Aff)
import Gargantext.Prelude
import Gargantext.Components.Nodes.Corpus.Chart.Predefined as P
import Gargantext.Prelude
import Gargantext.Routes (SessionRoute(NodeAPI))
import Gargantext.Sessions (Session, get, put)
import Gargantext.Types (NodeType(..))
......
src/Gargantext/Config/REST.purs
View file @ 0b03d8c1
module Gargantext.Config.REST where
import Affjax (defaultRequest, printResponseFormatError, request)
import Affjax.RequestBody (RequestBody(..), formData, formURLEncoded, string)
import Affjax.RequestBody (RequestBody(..), formData, formURLEncoded)
import Affjax.RequestHeader as ARH
import Affjax.ResponseFormat as ResponseFormat
import DOM.Simple.Console (log)
import Data.Argonaut (class DecodeJson, decodeJson, class EncodeJson, encodeJson)
import Data.Array as A
import Data.Either (Either(..))
import Data.Foldable (foldMap)
import Data.FormURLEncoded as FormURLEncoded
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.MediaType.Common (applicationFormURLEncoded, applicationJSON, multipartFormData)
import Data.Tuple (Tuple(..))
import Data.Tuple (Tuple)
import Effect.Aff (Aff, throwError)
import Effect.Class (liftEffect)
import Effect.Exception (error)
import Web.XHR.FormData as XHRFormData
import Gargantext.Prelude
import Gargantext.Utils.Reactix as R2
import Web.XHR.FormData as XHRFormData
type Token = String
......
src/Gargantext/Prelude.purs
View file @ 0b03d8c1
module Gargantext.Prelude (module Prelude, logs)
module Gargantext.Prelude (module Prelude, logs, id, class Read, read)
where
import Data.Maybe (Maybe)
import Prelude (class Applicative, class Apply, class Bind, class BooleanAlgebra, class Bounded, class Category, class CommutativeRing, class Discard, class DivisionRing, class Eq, class EuclideanRing, class Field, class Functor, class HeytingAlgebra, class Monad, class Monoid, class Ord, class Ring, class Semigroup, class Semigroupoid, class Semiring, class Show, type (~>), Ordering(..), Unit, Void, absurd, add, ap, append, apply, between, bind, bottom, clamp, compare, comparing, compose, conj, const, degree, discard, disj, eq, flap, flip, gcd, identity, ifM, join, lcm, liftA1, liftM1, map, max, mempty, min, mod, mul, negate, not, notEq, one, otherwise, pure, recip, show, sub, top, unit, unless, unlessM, void, when, whenM, zero, (#), ($), ($>), (&&), (*), (*>), (+), (-), (/), (/=), (<), (<#>), (<$), (<$>), (<*), (<*>), (<<<), (<=), (<=<), (<>), (<@>), (=<<), (==), (>), (>=), (>=>), (>>=), (>>>), (||))
import Effect.Console (log)
import Effect.Class (class MonadEffect, liftEffect)
-- | JL: Astonishingly, not in the prelude
-- AD: recent Preludes in Haskell much prefer identity
-- then id can be used as a variable name (in records for instance)
-- since records in Purescript are not the same as in Haskell
-- this behavior is questionable indeed.
id :: forall a. a -> a
id a = a
class Read a where
read :: String -> Maybe a
logs:: forall message effect.
(MonadEffect effect)
=> Show message
......@@ -13,3 +25,5 @@ logs:: forall message effect.
-> effect Unit
logs = liftEffect <<< log <<< show
src/Gargantext/Types.purs
View file @ 0b03d8c1
module Gargantext.Types where
import Prelude
import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson, jsonEmptyObject, (.:), (:=), (~>))
import Data.Array as A
import Data.Either (Either(..))
......@@ -10,8 +8,10 @@ import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Ord (genericCompare)
import Data.Generic.Rep.Show (genericShow)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), maybe)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Effect.Aff (Aff)
import Gargantext.Prelude (class Read, read)
import Prelude
import Prim.Row (class Union)
import URI.Query (Query)
......@@ -44,10 +44,11 @@ instance showTermSize :: Show TermSize where
show MonoTerm = "MonoTerm"
show MultiTerm = "MultiTerm"
readTermSize :: String -> Maybe TermSize
readTermSize "MonoTerm" = Just MonoTerm
readTermSize "MultiTerm" = Just MultiTerm
readTermSize _ = Nothing
instance readTermSize :: Read TermSize where
read :: String -> Maybe TermSize
read "MonoTerm" = Just MonoTerm
read "MultiTerm" = Just MultiTerm
read _ = Nothing
termSizes :: Array { desc :: String, mval :: Maybe TermSize }
termSizes = [ { desc: "All types", mval: Nothing }
......@@ -93,11 +94,12 @@ termListName GraphTerm = "Map List"
termListName StopTerm = "Stop List"
termListName CandidateTerm = "Candidate List"
readTermList :: String -> Maybe TermList
readTermList "GraphTerm" = Just GraphTerm
readTermList "StopTerm" = Just StopTerm
readTermList "CandidateTerm" = Just CandidateTerm
readTermList _ = Nothing
instance readTermList :: Read TermList where
read :: String -> Maybe TermList
read "GraphTerm" = Just GraphTerm
read "StopTerm" = Just StopTerm
read "CandidateTerm" = Just CandidateTerm
read _ = Nothing
termLists :: Array { desc :: String, mval :: Maybe TermList }
termLists = [ { desc: "All terms", mval: Nothing }
......@@ -176,30 +178,28 @@ instance showNodeType :: Show NodeType where
show NodeList = "NodeList"
show Texts = "NodeTexts"
readNodeType :: String -> NodeType
readNodeType "NodeUser" = NodeUser
readNodeType "NodeFolder" = Folder
readNodeType "NodeFolderPrivate" = FolderPrivate
readNodeType "NodeFolderShared" = FolderShared
readNodeType "NodeFolderPublic" = FolderPublic
readNodeType "NodeAnnuaire" = Annuaire
readNodeType "NodeDashboard" = Dashboard
readNodeType "Document" = Url_Document
readNodeType "NodeGraph" = Graph
readNodeType "NodePhylo" = Phylo
readNodeType "Individu" = Individu
readNodeType "Node" = Node
readNodeType "Nodes" = Nodes
readNodeType "NodeCorpus" = Corpus
readNodeType "NodeContact" = NodeContact
readNodeType "Tree" = Tree
readNodeType "NodeTeam" = Team
readNodeType "NodeList" = NodeList
readNodeType "NodeTexts" = Texts
readNodeType "Annuaire" = Annuaire
readNodeType _ = Error
instance readNodeType :: Read NodeType where
read "NodeUser" = Just NodeUser
read "NodeFolder" = Just Folder
read "NodeFolderPrivate" = Just FolderPrivate
read "NodeFolderShared" = Just FolderShared
read "NodeFolderPublic" = Just FolderPublic
read "NodeAnnuaire" = Just Annuaire
read "NodeDashboard" = Just Dashboard
read "Document" = Just Url_Document
read "NodeGraph" = Just Graph
read "NodePhylo" = Just Phylo
read "Individu" = Just Individu
read "Node" = Just Node
read "Nodes" = Just Nodes
read "NodeCorpus" = Just Corpus
read "NodeContact" = Just NodeContact
read "Tree" = Just Tree
read "NodeTeam" = Just Team
read "NodeList" = Just NodeList
read "NodeTexts" = Just Texts
read "Annuaire" = Just Annuaire
read _ = Nothing
fldr :: NodeType -> Boolean -> String
......@@ -254,7 +254,7 @@ instance eqNodeType :: Eq NodeType where
instance decodeJsonNodeType :: DecodeJson NodeType where
decodeJson json = do
obj <- decodeJson json
pure $ readNodeType obj
pure $ fromMaybe Error $ read obj
instance encodeJsonNodeType :: EncodeJson NodeType where
encodeJson nodeType = encodeJson $ show nodeType
......@@ -449,7 +449,10 @@ instance showTabType :: Show TabType where
type TableResult a = {count :: Int, docs :: Array a}
type AffTableResult a = Aff (TableResult a)
data Mode = Authors | Sources | Institutes | Terms
data Mode = Authors
| Sources
| Institutes
| Terms
derive instance genericMode :: Generic Mode _
instance showMode :: Show Mode where
......@@ -480,6 +483,8 @@ data AsyncTaskType = Form
| GraphT
| Query
| AddNode
| UpdateNode
derive instance genericAsyncTaskType :: Generic AsyncTaskType _
instance eqAsyncTaskType :: Eq AsyncTaskType where
eq = genericEq
......@@ -502,35 +507,47 @@ asyncTaskTypePath Form = "add/form/async/"
asyncTaskTypePath Query = "query/"
asyncTaskTypePath GraphT = "async/"
asyncTaskTypePath AddNode = "async/nobody/"
asyncTaskTypePath UpdateNode = "update/"
type AsyncTaskID = String
data AsyncTaskStatus = Running | Pending | Received | Started | Failed | Finished | Killed
data AsyncTaskStatus = Running
| Pending
| Received
| Started
| Failed
| Finished
| Killed
derive instance genericAsyncTaskStatus :: Generic AsyncTaskStatus _
instance showAsyncTaskStatus :: Show AsyncTaskStatus where
show = genericShow
derive instance eqAsyncTaskStatus :: Eq AsyncTaskStatus
instance encodeJsonAsyncTaskStatus :: EncodeJson AsyncTaskStatus where
encodeJson s = encodeJson $ show s
instance decodeJsonAsyncTaskStatus :: DecodeJson AsyncTaskStatus where
decodeJson json = do
obj <- decodeJson json
pure $ readAsyncTaskStatus obj
readAsyncTaskStatus :: String -> AsyncTaskStatus
readAsyncTaskStatus "IsFailure" = Failed
readAsyncTaskStatus "IsFinished" = Finished
readAsyncTaskStatus "IsKilled" = Killed
readAsyncTaskStatus "IsPending" = Pending
readAsyncTaskStatus "IsReceived" = Received
readAsyncTaskStatus "IsRunning" = Running
readAsyncTaskStatus "IsStarted" = Started
readAsyncTaskStatus _ = Running
newtype AsyncTask = AsyncTask {
id :: AsyncTaskID
, status :: AsyncTaskStatus
}
pure $ fromMaybe Running $ read obj
instance readAsyncTaskStatus :: Read AsyncTaskStatus where
read "IsFailure" = Just Failed
read "IsFinished" = Just Finished
read "IsKilled" = Just Killed
read "IsPending" = Just Pending
read "IsReceived" = Just Received
read "IsRunning" = Just Running
read "IsStarted" = Just Started
read _ = Nothing
newtype AsyncTask =
AsyncTask { id :: AsyncTaskID
, status :: AsyncTaskStatus
}
derive instance genericAsyncTask :: Generic AsyncTask _
instance eqAsyncTask :: Eq AsyncTask where
eq = genericEq
......@@ -541,8 +558,8 @@ instance encodeJsonAsyncTask :: EncodeJson AsyncTask where
~> jsonEmptyObject
instance decodeJsonAsyncTask :: DecodeJson AsyncTask where
decodeJson json = do
obj <- decodeJson json
id <- obj .: "id"
obj <- decodeJson json
id <- obj .: "id"
status <- obj .: "status"
pure $ AsyncTask { id, status }
......@@ -560,9 +577,9 @@ instance encodeJsonAsyncTaskWithType :: EncodeJson AsyncTaskWithType where
~> jsonEmptyObject
instance decodeJsonAsyncTaskWithType :: DecodeJson AsyncTaskWithType where
decodeJson json = do
obj <- decodeJson json
obj <- decodeJson json
task <- obj .: "task"
typ <- obj .: "typ"
typ <- obj .: "typ"
pure $ AsyncTaskWithType { task, typ }
newtype AsyncProgress = AsyncProgress {
......@@ -573,9 +590,9 @@ newtype AsyncProgress = AsyncProgress {
derive instance genericAsyncProgress :: Generic AsyncProgress _
instance decodeJsonAsyncProgress :: DecodeJson AsyncProgress where
decodeJson json = do
obj <- decodeJson json
id <- obj .: "id"
log <- obj .: "log"
obj <- decodeJson json
id <- obj .: "id"
log <- obj .: "log"
status <- obj .: "status"
pure $ AsyncProgress {id, log, status}
......@@ -588,9 +605,9 @@ newtype AsyncTaskLog = AsyncTaskLog {
derive instance genericAsyncTaskLog :: Generic AsyncTaskLog _
instance decodeJsonAsyncTaskLog :: DecodeJson AsyncTaskLog where
decodeJson json = do
obj <- decodeJson json
events <- obj .: "events"
failed <- obj .: "failed"
obj <- decodeJson json
events <- obj .: "events"
failed <- obj .: "failed"
remaining <- obj .: "remaining"
succeeded <- obj .: "succeeded"
pure $ AsyncTaskLog {events, failed, remaining, succeeded}
......
src/Gargantext/Utils.purs
View file @ 0b03d8c1
......@@ -7,9 +7,9 @@ import Data.Set as Set
import Data.Set (Set)
import Data.String as S
-- | Astonishingly, not in the prelude
id :: forall a. a -> a
id a = a
-- | TODO (hard coded)
csrfMiddlewareToken :: String
csrfMiddlewareToken = "Wy52D2nor8kC1r1Y4GrsrSIxQ2eqW8UwkdiQQshMoRwobzU4uldknRUhP0j4WcEM"
setterv :: forall nt record field.
Newtype nt record
......@@ -45,15 +45,12 @@ invertOrdering LT = GT
invertOrdering GT = LT
invertOrdering EQ = EQ
csrfMiddlewareToken :: String
csrfMiddlewareToken = "Wy52D2nor8kC1r1Y4GrsrSIxQ2eqW8UwkdiQQshMoRwobzU4uldknRUhP0j4WcEM"
-- A lens that always returns unit
_unit :: forall s. Lens' s Unit
_unit = lens (\_ -> unit) (\s _ -> s)
glyphicon :: String -> String
glyphicon t = "btn glyphitem glyphicon glyphicon-" <> t
glyphicon t = "btn glyphitem fa fa-" <> t
glyphiconActive :: String -> Boolean -> String
glyphiconActive icon b = glyphicon icon <> if b then " active" else ""
......
src/Gargantext/Utils/Argonaut.purs
View file @ 0b03d8c1
......@@ -5,7 +5,7 @@ import Prelude
import Control.Alt ((<|>))
import Data.Argonaut (Json)
import Data.Argonaut as Argonaut
import Data.Either (Either)
import Data.Either (Either(..))
import Data.Generic.Rep as GR
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
......@@ -56,6 +56,11 @@ instance genericSumDecodeJsonRepConstructor ::
argument <- genericSumDecodeJsonRep inner
pure $ GR.Constructor argument
instance genericSumDecodeJsonRepNoArguments ::
GenericSumDecodeJsonRep (GR.NoArguments) where
genericSumDecodeJsonRep _ = do
pure GR.NoArguments
instance genericSumDecodeJsonRepArgument ::
( Argonaut.DecodeJson a
) => GenericSumDecodeJsonRep (GR.Argument a) where
......@@ -79,7 +84,66 @@ instance genericSumEncodeJsonRepConstructor ::
let argument = genericSumEncodeJsonRep inner
Argonaut.jsonSingletonObject name argument
instance genericSumEncodeJsonRepNoArguments ::
GenericSumEncodeJsonRep GR.NoArguments where
genericSumEncodeJsonRep GR.NoArguments = Argonaut.jsonNull
instance genericSumEncodeJsonRepArgument ::
( Argonaut.EncodeJson a
) => GenericSumEncodeJsonRep (GR.Argument a) where
genericSumEncodeJsonRep (GR.Argument f) = Argonaut.encodeJson f
genericEnumDecodeJson :: forall a rep
. GR.Generic a rep
=> GenericEnumDecodeJson rep
=> Json
-> Either String a
genericEnumDecodeJson f =
GR.to <$> genericEnumDecodeJsonRep f
-- | Generic Enum Sum Representations, with constructor names as strings
class GenericEnumDecodeJson rep where
genericEnumDecodeJsonRep :: Json -> Either String rep
instance sumEnumDecodeJsonRep ::
( GenericEnumDecodeJson a
, GenericEnumDecodeJson b
) => GenericEnumDecodeJson (GR.Sum a b) where
genericEnumDecodeJsonRep f
= GR.Inl <$> genericEnumDecodeJsonRep f
<|> GR.Inr <$> genericEnumDecodeJsonRep f
instance constructorEnumSumRep ::
( IsSymbol name
) => GenericEnumDecodeJson (GR.Constructor name GR.NoArguments) where
genericEnumDecodeJsonRep f = do
s <- Argonaut.decodeJson f
if s == name
then pure $ GR.Constructor GR.NoArguments
else Left $ "Enum string " <> s <> " did not match expected string " <> name
where
name = reflectSymbol (SProxy :: SProxy name)
genericEnumEncodeJson :: forall a rep
. GR.Generic a rep
=> GenericEnumEncodeJson rep
=> a
-> Json
genericEnumEncodeJson f =
genericEnumEncodeJsonRep $ GR.from f
-- | Generic Enum Sum Representations, with constructor names as strings
class GenericEnumEncodeJson rep where
genericEnumEncodeJsonRep :: rep -> Json
instance sumGenericEnumEncodeJson ::
( GenericEnumEncodeJson a
, GenericEnumEncodeJson b
) => GenericEnumEncodeJson (GR.Sum a b) where
genericEnumEncodeJsonRep (GR.Inl x) = genericEnumEncodeJsonRep x
genericEnumEncodeJsonRep (GR.Inr x) = genericEnumEncodeJsonRep x
instance constructorGenericEnumEncodeJson ::
( IsSymbol name
) => GenericEnumEncodeJson (GR.Constructor name GR.NoArguments) where
genericEnumEncodeJsonRep _ = Argonaut.encodeJson $ reflectSymbol (SProxy :: SProxy name)
src/Gargantext/Utils/Popover.purs
View file @ 0b03d8c1
module Gargantext.Utils.Popover where
import Data.Maybe (Maybe(..), maybe)
import Data.Maybe (maybe)
import Data.Nullable (Nullable, toMaybe)
import DOM.Simple as DOM
import DOM.Simple.Console (log2)
import Effect (Effect)
import Effect.Uncurried (EffectFn2, runEffectFn2)
import FFI.Simple ((..), (...))
import Reactix as R
import Gargantext.Prelude
......
test/Gargantext/Utils/Spec.purs
View file @ 0b03d8c1
......@@ -7,7 +7,7 @@ import Data.Either (Either(..), isLeft)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Gargantext.Utils as GU
import Gargantext.Utils.Argonaut (genericSumDecodeJson, genericSumEncodeJson)
import Gargantext.Utils.Argonaut (genericEnumDecodeJson, genericEnumEncodeJson, genericSumDecodeJson, genericSumEncodeJson)
import Gargantext.Utils.Crypto as GUC
import Gargantext.Utils.Math as GUM
import Test.Spec (Spec, describe, it)
......@@ -27,6 +27,20 @@ instance decodeJsonFruit :: Argonaut.DecodeJson Fruit where
instance encodeJsonFruit :: Argonaut.EncodeJson Fruit where
encodeJson = genericSumEncodeJson
data EnumTest
= Member1
| Member2
| Member3
derive instance eqEnumTest :: Eq EnumTest
derive instance genericEnumTest :: Generic EnumTest _
instance showEnumTest :: Show EnumTest where
show = genericShow
instance decodeJsonEnumTest :: Argonaut.DecodeJson EnumTest where
decodeJson = genericEnumDecodeJson
instance encodeJsonEnumTest :: Argonaut.EncodeJson EnumTest where
encodeJson = genericEnumEncodeJson
spec :: Spec Unit
spec =
describe "G.Utils" do
......@@ -76,3 +90,26 @@ spec =
let result2' = Argonaut.decodeJson result2
Argonaut.stringify result2 `shouldEqual` """{"Gravy":"hi"}"""
result2' `shouldEqual` Right input2
it "genericEnumDecodeJson works" do
let result1 = Argonaut.decodeJson =<< Argonaut.jsonParser "\"Member1\""
result1 `shouldEqual` Right Member1
let result2 = Argonaut.decodeJson =<< Argonaut.jsonParser "\"Member2\""
result2 `shouldEqual` Right Member2
let result3 = Argonaut.decodeJson =<< Argonaut.jsonParser "\"Failure\""
isLeft (result3 :: Either String EnumTest) `shouldEqual` true
it "genericSumEncodeJson works and loops back with decode" do
let input1 = Member1
let result1 = Argonaut.encodeJson input1
let result1' = Argonaut.decodeJson result1
Argonaut.stringify result1 `shouldEqual` "\"Member1\""
result1' `shouldEqual` Right input1
let input2 = Member2
let result2 = Argonaut.encodeJson input2
let result2' = Argonaut.decodeJson result2
Argonaut.stringify result2 `shouldEqual` "\"Member2\""
result2' `shouldEqual` Right input2
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