Merge branch 'dev' into dev-corpus-query-async

dist/styles/CodeEditor.css

+.code-editor-heading {
+  display: flex;
+}
+.code-editor-heading .renameable {
+  flex-grow: 2;
+}
+.code-editor-heading .renameable .text {
+  padding-right: 10px;
+}
+.code-editor-heading .buttons-right {
+  display: flex;
+  justify-content: flex-end;
+}
+
 .code-editor .toolbar {
   display: flex;
   justify-content: flex-start;
@@ -7,24 +21,101 @@
   display: flex;
   width: 100%;
 }
-.code-editor .editor .code {
+.code-editor .editor .code-area {
   flex-grow: 1;
+  max-height: 200px;
+  overflow: auto;
+}
+.code-editor .editor .code-area .code-container {
+  background-color: #fafafa;
+  box-sizing: border-box;
+  position: relative;
+  font-family: Fira code, Fira Mono, Consolas, Menlo, Courier, monospace;
+  font-size: 12px;
+  font-variant-ligatures: common-ligatures;
+  line-height: 1.5;
+  overflow: hidden;
+  padding: 0px;
+  text-align: left;
+}
+.code-editor .editor .code-area .code-container textarea {
+  border: 0px;
+  color: inherit;
+  position: absolute;
+  left: 0px;
+  top: 0px;
+  resize: none;
+  height: 100%;
+  overflow: hidden;
+  width: 100%;
+  -webkit-text-fill-color: transparent;
+  box-sizing: inherit;
+  display: inherit;
+  margin: 0px;
+  padding: 10px;
+  overflow-wrap: break-word;
+  white-space: pre-wrap;
+  word-break: keep-all;
+  font-family: inherit;
+  font-size: inherit;
+  font-style: inherit;
+  font-variant-ligatures: inherit;
+  font-weight: inherit;
+  letter-spacing: inherit;
+  line-height: inherit;
+  text-indent: inherit;
+  text-rendering: inherit;
+  text-transform: inherit;
 }
-.code-editor .editor .code code {
-  background-color: #f7f7f9;
+.code-editor .editor .code-area .code-container pre {
+  background: rgba(0, 0, 0, 0) none repeat scroll 0% 0%;
+  border: 0px none;
   color: #000;
-  display: block;
-  height: 500px;
+  pointer-events: none;
+  position: relative;
+  box-sizing: inherit;
+  display: inherit;
+  margin: 0px;
+  padding: 10px;
+  overflow-wrap: break-word;
+  white-space: pre-wrap;
+  word-break: keep-all;
+  font-family: inherit;
+  font-size: inherit;
+  font-style: inherit;
+  font-variant-ligatures: inherit;
+  font-weight: inherit;
+  letter-spacing: inherit;
+  line-height: inherit;
+  text-indent: inherit;
+  text-rendering: inherit;
+  text-transform: inherit;
+}
+.code-editor .editor .v-divider {
+  border-left: 1px solid gray;
+  cursor: sw-resize;
+  height: 100%;
+  margin-left: 5px;
+  margin-right: 5px;
+  width: 1px;
 }
 .code-editor .editor .html {
   flex-grow: 2;
   margin-left: 25px;
   padding-left: 25px;
 }
-.code-editor .editor .html ul li {
+.code-editor .editor .html.language-haskell {
+  font-family: Fira code, Fira Mono, Consolas, Menlo, Courier, monospace;
+  white-space: pre;
+}
+.code-editor .editor .html.language-json {
+  font-family: Fira code, Fira Mono, Consolas, Menlo, Courier, monospace;
+  white-space: pre;
+}
+.code-editor .editor .html.language-md ul li {
   list-style: disc !important;
 }
-.code-editor .editor .html ol li {
+.code-editor .editor .html.language-md ol li {
   list-style: decimal !important;
 }
 

dist/styles/CodeEditor.sass

+@mixin font-inherit()
+  font-family: inherit
+  font-size: inherit
+  font-style: inherit
+  font-variant-ligatures: inherit
+  font-weight: inherit
+  letter-spacing: inherit
+  line-height: inherit
+  text-indent: inherit
+  text-rendering: inherit
+  text-transform: inherit
+
+@mixin common-overlay-props()
+  box-sizing: inherit
+  display: inherit
+  margin: 0px
+  padding: 10px
+  overflow-wrap: break-word
+  white-space: pre-wrap
+  word-break: keep-all
+
+.code-editor-heading
+  display: flex
+  //justify-content: space-between
+  .renameable
+    flex-grow: 2
+    .text
+      padding-right: 10px
+  .buttons-right
+    display: flex
+    justify-content: flex-end
+
 .code-editor
   .toolbar
     display: flex
@@ -6,17 +38,60 @@
   .editor
     display: flex
     width: 100%
-    .code
+    .code-area
       flex-grow: 1
-      code
-        background-color: #f7f7f9
+      max-height: 200px
+      overflow: auto
+      .code-container
+        background-color: #fafafa
+        box-sizing: border-box
+        position: relative
+        font-family: Fira code,Fira Mono,Consolas,Menlo,Courier,monospace
+        font-size: 12px
+        font-variant-ligatures: common-ligatures
+        line-height: 1.5
+        overflow: hidden
+        padding: 0px
+        text-align: left
+        textarea
+          border: 0px
+          color: inherit
+          position: absolute
+          left: 0px
+          top: 0px
+          resize: none
+          height: 100%
+          overflow: hidden
+          width: 100%
+          -webkit-text-fill-color: transparent
+          @include common-overlay-props()
+          @include font-inherit()
+        pre
+          background: rgba(0, 0, 0, 0) none repeat scroll 0% 0%
+          border: 0px none
           color: #000
-        display: block
-        height: 500px
+          pointer-events: none
+          position: relative
+          @include common-overlay-props()
+          @include font-inherit()
+    .v-divider
+      border-left: 1px solid gray
+      cursor: sw-resize
+      height: 100%
+      margin-left: 5px
+      margin-right: 5px
+      width: 1px
     .html
       flex-grow: 2
       margin-left: 25px
       padding-left: 25px
+      &.language-haskell
+        font-family: Fira code,Fira Mono,Consolas,Menlo,Courier,monospace
+        white-space: pre
+      &.language-json
+        font-family: Fira code,Fira Mono,Consolas,Menlo,Courier,monospace
+        white-space: pre
+      &.language-md
         ul
           li
             list-style: disc !important

package.json

@@ -22,6 +22,7 @@
         "create-react-class": "^15.6.3",
         "echarts": "^4.1.0",
         "echarts-for-react": "^2.0.14",
+        "highlightjs": "^9.16.2",
         "prop-types": "15.6.2",
         "react": "^16.10",
         "react-dom": "^16.10",

psc-package.json

@@ -34,6 +34,7 @@
     "spec-quickcheck",
     "string-parsers",
     "strings",
+    "stringutils",
     "thermite",
     "tuples-native",
     "uint",

src/Gargantext/Components/App.purs

@@ -57,7 +57,7 @@ appCpt = R.hooksComponent "G.C.App.app" cpt where
           Home  -> forested $ homeLayout EN
           Login -> login { sessions, backends, visible: showLogin }
           Folder sid _      -> withSession sid $ \_ -> forested (folder {})
-          Corpus sid nodeId -> withSession sid $ \_ -> forested $ corpusLayout { nodeId }
+          Corpus sid nodeId -> withSession sid $ \session -> forested $ corpusLayout { nodeId, session }
           Texts sid nodeId  -> withSession sid $ \session -> forested $ textsLayout { nodeId, session, frontends }
           Lists sid nodeId  -> withSession sid $ \session -> forested $ listsLayout { nodeId, session }
           Dashboard sid _nodeId  -> withSession sid $ \session -> forested $ dashboardLayout {}

src/Gargantext/Components/CodeEditor.purs

@@ -2,32 +2,33 @@ module Gargantext.Components.CodeEditor where
 
 import Data.Argonaut.Parser (jsonParser)
 import Data.Either (either, Either(..))
+import Data.Generic.Rep (class Generic)
+import Data.Generic.Rep.Eq (genericEq)
+import Data.Generic.Rep.Show (genericShow)
 import Data.Maybe (Maybe(..))
 import Data.Nullable (Nullable, null, toMaybe)
-import Data.Tuple (fst, snd)
+import Data.String.Utils (endsWith)
+import Data.Tuple (fst)
 import Data.Tuple.Nested ((/\))
-import DOM.Simple.Console (log, log2)
 import DOM.Simple.Types (Element)
 import Effect (Effect)
 import FFI.Simple ((.=), delay)
-import Data.Generic.Rep (class Generic)
-import Data.Generic.Rep.Eq (genericEq)
-import Data.Generic.Rep.Show (genericShow)
 import Reactix as R
 import Reactix.DOM.HTML as H
 import Text.Markdown.SlamDown.Parser (parseMd)
 import Text.Markdown.SlamDown.Smolder as MD
-import Text.Markdown.SlamDown.Syntax (SlamDownP(..))
-import Text.Smolder.Renderer.String (render)
+import Text.Markdown.SlamDown.Syntax (SlamDownP)
+import Text.Smolder.Renderer.String as Smolder
 
 import Gargantext.Prelude
+import Gargantext.Utils.HighlightJS as HLJS
 import Gargantext.Utils.Reactix as R2
 
 type Code = String
 type Html = String
 type Error = String
 
-data CodeType = JSON | Markdown
+data CodeType = Haskell | JSON | Markdown
 derive instance genericCodeType :: Generic CodeType _
 instance eqCodeType :: Eq CodeType where
   eq = genericEq
@@ -42,121 +43,183 @@ instance showViewType :: Show ViewType where
   show = genericShow
 
 type Props =
-  ( code :: String
+  ( code :: Code
   , defaultCodeType :: CodeType
-  , onChange :: String -> Effect Unit
+  , onChange :: CodeType -> Code -> Effect Unit
   )
 
-compile :: CodeType -> Code -> Either Error Html
-compile JSON code = result
+-- Fixes newlines in code
+-- This is useful eg for proper rendering of the textarea overlay
+codeNlFix :: CodeType -> Code -> Code
+codeNlFix _ "" = " "
+codeNlFix _ c = if endsWith "\n" c then (c <> " ") else c
+
+render :: CodeType -> Code -> Either Error Html
+render Haskell code = Right $ renderHaskell $ codeNlFix Haskell code
+render JSON code = result
   where
     parsedE = jsonParser code
     result = case parsedE of
       Left err -> Left err
-      Right parsed -> Right $ "<pre>" <> (R2.stringify parsed 2) <> "</pre>"
-compile Markdown code = Right $ compileMd code
+      Right parsed -> Right $ R2.stringify parsed 2
+render Markdown code = Right $ renderMd $ codeNlFix Markdown code
+
+previewPostProcess :: CodeType -> Element -> Effect Unit
+previewPostProcess Haskell htmlEl = do
+  HLJS.highlightBlock htmlEl
+previewPostProcess JSON htmlEl = do
+  HLJS.highlightBlock htmlEl
+previewPostProcess Markdown _ = pure unit
 
 -- TODO Replace with markdown-it?
 -- https://pursuit.purescript.org/packages/purescript-markdown-it
-compileMd' :: forall e. MD.ToMarkupOptions e -> String -> String
-compileMd' options input =
-  either identity (MD.toMarkup' options >>> render)
+renderMd' :: forall e. MD.ToMarkupOptions e -> String -> String
+renderMd' options input =
+  either identity (MD.toMarkup' options >>> Smolder.render)
   (parseMd input :: Either String (SlamDownP String))
 
-compileMd :: String -> String
-compileMd = compileMd' MD.defaultToMarkupOptions
+renderMd :: String -> String
+renderMd = renderMd' MD.defaultToMarkupOptions
+
+renderHaskell :: String -> String
+renderHaskell s = s
 
 codeEditor :: Record Props -> R.Element
 codeEditor p = R.createElement codeEditorCpt p []
 
+-- The code editor contains 3 components:
+-- - a hidden textarea
+-- - textarea code overlay
+-- - html preview
+-- The overlay is to provide seamless syntax highlighting on top of the textarea.
+-- I took the idea from: https://github.com/satya164/react-simple-code-editor
 codeEditorCpt :: R.Component Props
-codeEditorCpt = R.hooksComponent "G.C.CodeEditor" cpt
+codeEditorCpt = R.hooksComponent "G.C.CE.CodeEditor" cpt
   where
     cpt {code, defaultCodeType, onChange} _ = do
-      htmlRef <- R.useRef null
-      codeRef <- R.useRef null
-      editorCodeRef <- R.useRef code
-      codeType <- R.useState' defaultCodeType
-      error <- R.useState' Nothing
-      viewType <- R.useState' Both
+      controls <- initControls code defaultCodeType
 
       -- Initial rendering of elements with given data
 
       -- Note: delay is necessary here, otherwise initially the HTML won't get
-      -- rendered (mDiv is still null)
+      -- rendered (DOM Element refs are still null)
       R.useEffectOnce $ delay unit $ \_ -> do
-        _ <- renderHtml (fst codeType) code htmlRef error
+        _ <- renderHtml code controls
         pure $ pure unit
 
       R.useEffectOnce $ delay unit $ \_ -> do
-        let mCodeEl = toMaybe $ R.readRef codeRef
-        case mCodeEl of
-          Nothing -> pure $ pure unit
-          Just codeEl -> do
-            _ <- pure $ (codeEl .= "innerText") code
+        _ <- setCodeOverlay controls code
         pure $ pure unit
 
       pure $ H.div { className: "code-editor" } [
-        H.div { className: "row toolbar" } [
-             codeTypeSelector {codeType, onChange: onChangeCodeType editorCodeRef htmlRef error}
-           , viewTypeSelector {state: viewType}
-           ]
+          toolbar {controls, onChange}
         , H.div { className: "row error" } [
-           errorComponent {error}
+           errorComponent {error: controls.error}
         ]
         , H.div { className: "row editor" } [
-           H.div { className: "code " <> (codeHidden $ fst viewType) } [
-              H.code { className: ""
-                     , contentEditable: "true"
-                     , ref: codeRef
+           H.div { className: "code-area " <> (codeHidden $ fst controls.viewType) } [
+             H.div { className: "code-container" } [
+               H.textarea { defaultValue: code
+                          , on: { change: onEditChange controls onChange }
+                          , placeholder: "Type some code..."
+                          , ref: controls.codeElRef } [ ]
+               , H.pre  { className: (langClass $ fst controls.codeType)
+                          -- , contentEditable: "true"
+                        , ref: controls.codeOverlayElRef
                         , rows: 30
-                     , on: { input: onEditChange (fst codeType) codeRef htmlRef editorCodeRef error }
+                          --, on: { input: onEditChange (fst codeType) codeElRef htmlRef editorCodeRef error }
                         } []
                ]
-           , H.div { ref: htmlRef, className: "html " <> (previewHidden $ fst viewType) } []
+             ]
+           , H.div { className: "v-divider " <> (dividerHidden $ fst controls.viewType) } [ H.text " " ]
+           , H.div { className: "html " <> (langClass $ fst controls.codeType) <> (previewHidden $ fst controls.viewType)
+                   , ref: controls.htmlElRef
+                   } []
            ]
         ]
 
     codeHidden :: ViewType -> String
     codeHidden Code = ""
     codeHidden Both = ""
-    codeHidden _ = "hidden"
+    codeHidden _ = " hidden"
+
+    dividerHidden :: ViewType -> String
+    dividerHidden Both = ""
+    dividerHidden _ = " hidden"
+
+    langClass :: CodeType -> String
+    langClass Haskell = " language-haskell"
+    langClass JSON = " language-json"
+    langClass Markdown = " language-md"
 
     previewHidden :: ViewType -> String
     previewHidden Preview = ""
     previewHidden Both = ""
-    previewHidden _ = "hidden"
-
-    -- Handle rerendering of preview when viewType changed
-    onChangeCodeType :: R.Ref String -> R.Ref (Nullable Element) -> R.State (Maybe Error) -> CodeType -> Effect Unit
-    onChangeCodeType editorCodeRef htmlRef error codeType = do
-        _ <- renderHtml codeType (R.readRef editorCodeRef) htmlRef error
+    previewHidden _ = " hidden"
+
+    onEditChange :: forall e. Record Controls -> (CodeType -> Code -> Effect Unit) -> e -> Effect Unit
+    onEditChange controls@{codeElRef, codeOverlayElRef, codeType: (codeType /\ _), editorCodeRef} onChange e = do
+      let code = R2.unsafeEventValue e
+      R.setRef editorCodeRef code
+      setCodeOverlay controls code
+      renderHtml (R.readRef controls.editorCodeRef) controls
+      onChange codeType code
+
+setCodeOverlay :: Record Controls -> Code -> Effect Unit
+setCodeOverlay {codeOverlayElRef, codeType: (codeType /\ _)} code = do
+  let mCodeOverlayEl = toMaybe $ R.readRef codeOverlayElRef
+  _ <- case mCodeOverlayEl of
+    Nothing -> pure unit
+    Just codeOverlayEl -> do
+      _ <- pure $ (codeOverlayEl .= "innerText") $ codeNlFix codeType code
+      HLJS.highlightBlock codeOverlayEl
       pure unit
-
-    onEditChange :: forall e. CodeType -> R.Ref (Nullable Element) -> R.Ref (Nullable Element) -> R.Ref String -> R.State (Maybe Error) -> e -> Effect Unit
-    onEditChange codeType codeRef htmlRef editorCodeRef error e = do
-      log2 "[onChange] e" e
-      let mCode = toMaybe $ R.readRef codeRef
-      case mCode of
-        Nothing -> log "[onChange] mCode = Nothing"
-        Just code -> do
-          R.setRef editorCodeRef $ R2.innerText code
   pure unit
-      renderHtml codeType (R.readRef editorCodeRef) htmlRef error
 
-    renderHtml :: CodeType -> Code -> R.Ref (Nullable Element) -> R.State (Maybe Error) -> Effect Unit
-    renderHtml codeType code htmlRef (_ /\ setError) =
-      case (toMaybe $ R.readRef htmlRef) of
+renderHtml :: Code -> Record Controls -> Effect Unit
+renderHtml code {codeType: (codeType /\ _), htmlElRef, error: (_ /\ setError)} =
+  case (toMaybe $ R.readRef htmlElRef) of
     Nothing -> pure unit
     Just htmlEl -> do
-          case compile codeType code of
+      case render codeType code of
         Left err -> do
           setError $ const $ Just err
-            Right compiled -> do
+        Right rendered -> do
           setError $ const Nothing
-              _ <- pure $ (htmlEl .= "innerHTML") compiled
+          _ <- pure $ (htmlEl .= "innerHTML") rendered
+          previewPostProcess codeType htmlEl
           pure unit
 
+type ToolbarProps = (
+    controls :: Record Controls
+  , onChange :: CodeType -> Code -> Effect Unit
+  )
+
+toolbar :: Record ToolbarProps -> R.Element
+toolbar p = R.createElement toolbarCpt p []
+
+toolbarCpt :: R.Component ToolbarProps
+toolbarCpt = R.hooksComponent "G.C.CE.toolbar" cpt
+  where
+    cpt props@{controls: {codeType, error, viewType}} _ = do
+      pure $
+        H.div { className: "row toolbar" } [
+             codeTypeSelector {
+                  codeType
+                , onChange: onChangeCodeType props
+                }
+           , viewTypeSelector {state: viewType}
+           ]
+
+    -- Handle rerendering of preview when viewType changed
+    onChangeCodeType :: forall e. Record ToolbarProps -> e -> Effect Unit
+    onChangeCodeType {controls, onChange} _ = do
+      setCodeOverlay controls code
+      renderHtml code controls
+      onChange (fst controls.codeType) code
+      where
+        code = R.readRef controls.editorCodeRef
+
 
 type ErrorComponentProps =
   (
@@ -167,7 +230,7 @@ errorComponent :: Record ErrorComponentProps -> R.Element
 errorComponent p = R.createElement errorComponentCpt p []
 
 errorComponentCpt :: R.Component ErrorComponentProps
-errorComponentCpt = R.hooksComponent "G.C.ErrorComponent" cpt
+errorComponentCpt = R.hooksComponent "G.C.CE.ErrorComponent" cpt
   where
     cpt {error: (Nothing /\ _)} _ = pure $ H.div {} []
     cpt {error: ((Just error) /\ _)} _ = do
@@ -184,14 +247,14 @@ codeTypeSelector :: Record CodeTypeSelectorProps -> R.Element
 codeTypeSelector p = R.createElement codeTypeSelectorCpt p []
 
 codeTypeSelectorCpt :: R.Component CodeTypeSelectorProps
-codeTypeSelectorCpt = R.hooksComponent "G.C.CodeTypeSelector" cpt
+codeTypeSelectorCpt = R.hooksComponent "G.C.CE.CodeTypeSelector" cpt
   where
     cpt {codeType, onChange} _ = do
       pure $ R2.select { className: "form-control"
                 , on: { change: onSelectChange codeType onChange }
                 , style: { width: "150px" }
                 , value: show $ fst codeType }
-        (option <$> [JSON, Markdown])
+        (option <$> [Haskell, JSON, Markdown])
 
     option :: CodeType -> R.Element
     option value = H.option { value: show value } [ H.text $ show value ]
@@ -199,6 +262,7 @@ codeTypeSelectorCpt = R.hooksComponent "G.C.CodeTypeSelector" cpt
     onSelectChange :: forall e. R.State CodeType -> (CodeType -> Effect Unit) -> e -> Effect Unit
     onSelectChange (_ /\ setCodeType) onChange e = do
       let codeType = case value of
+            "Haskell"  -> Haskell
             "JSON"     -> JSON
             "Markdown" -> Markdown
             _          -> Markdown
@@ -217,7 +281,7 @@ viewTypeSelector :: Record ViewTypeSelectorProps -> R.Element
 viewTypeSelector p = R.createElement viewTypeSelectorCpt p []
 
 viewTypeSelectorCpt :: R.Component ViewTypeSelectorProps
-viewTypeSelectorCpt = R.hooksComponent "G.C.ViewTypeSelector" cpt
+viewTypeSelectorCpt = R.hooksComponent "G.C.CE.ViewTypeSelector" cpt
   where
     cpt {state} _ =
       pure $ H.div { className: "btn-group" } [
@@ -242,3 +306,34 @@ viewTypeSelectorCpt = R.hooksComponent "G.C.ViewTypeSelector" cpt
     icon Preview = "glyphicon-eye-open"
     icon Both = "glyphicon-transfer"
     icon Code = "glyphicon-pencil"
+
+type Controls =
+  (
+      codeElRef :: R.Ref (Nullable Element)
+    , codeType :: R.State CodeType
+    , codeOverlayElRef :: R.Ref (Nullable Element)
+    , editorCodeRef :: R.Ref Code
+    , error :: R.State (Maybe Error)
+    , htmlElRef :: R.Ref (Nullable Element)
+    , viewType :: R.State ViewType
+  )
+
+initControls :: Code -> CodeType -> R.Hooks (Record Controls)
+initControls code defaultCodeType = do
+  htmlElRef <- R.useRef null
+  codeElRef <- R.useRef null
+  codeOverlayElRef <- R.useRef null
+  codeType <- R.useState' defaultCodeType
+  editorCodeRef <- R.useRef code
+  error <- R.useState' Nothing
+  viewType <- R.useState' Both
+
+  pure $ {
+      codeElRef
+    , codeType
+    , codeOverlayElRef
+    , editorCodeRef
+    , error
+    , htmlElRef
+    , viewType
+    }

src/Gargantext/Components/Forest/Tree/Node/ProgressBar.purs

@@ -14,6 +14,7 @@ import Gargantext.Routes (SessionRoute(..))
 import Gargantext.Sessions (Session, get)
 import Gargantext.Types as GT
 import Partial.Unsafe (unsafePartial)
+
 import Reactix as R
 import Reactix.DOM.HTML as H
 

src/Gargantext/Components/GraphExplorer/Sidebar.purs

@@ -15,7 +15,6 @@ import Data.Tuple (fst, snd)
 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

src/Gargantext/Components/MarkdownEditor.purs

-module Gargantext.Components.MarkdownEditor where
-
-import Data.Either (either, Either(..))
-import Data.Maybe (Maybe(..))
-import Data.Nullable (Nullable, null, toMaybe)
-import Data.Tuple (fst)
-import Data.Tuple.Nested ((/\))
-import DOM.Simple.Console (log2)
-import DOM.Simple.Types (Element)
-import Effect (Effect)
-import FFI.Simple ((.=), delay)
-import Prelude (($), (>>>), Unit, bind, const, discard, identity, pure, unit)
-import Reactix as R
-import Reactix.DOM.HTML as H
-import Text.Markdown.SlamDown.Parser (parseMd)
-import Text.Markdown.SlamDown.Smolder as MD
-import Text.Markdown.SlamDown.Syntax (SlamDownP(..))
-import Text.Smolder.Renderer.String (render)
-
-import Gargantext.Utils.Reactix as R2
-
-type Props =
-  ( md :: String
-  , nodeId :: Int
-  )
-
-compileMd' :: forall e. MD.ToMarkupOptions e -> String -> String
-compileMd' options input =
-  either identity (MD.toMarkup' options >>> render)
-  (parseMd input :: Either String (SlamDownP String))
-
-compileMd :: String -> String
-compileMd = compileMd' MD.defaultToMarkupOptions
-
-markdownEditor :: Record Props -> R.Element
-markdownEditor p = R.createElement markdownEditorCpt p []
-
-markdownEditorCpt :: R.Component Props
-markdownEditorCpt = R.hooksComponent "G.C.MarkdownEditor" cpt
-  where
-    cpt {md, nodeId} _ = do
-      ref <- R.useRef null
-      editedMd <- R.useState' md
-
-      -- Note: delay is necessary here, otherwise initially the HTML won't get
-      -- rendered (mDiv is still null)
-      R.useEffect $ delay unit $ \_ -> do
-        let mDiv = toMaybe $ R.readRef ref
-        case mDiv of
-          Nothing -> pure $ pure unit
-          Just d -> do
-            _ <- pure $ (d .= "innerHTML") $ compileMd $ fst editedMd
-            pure $ pure unit
-
-      pure $ H.div { className: "markdown-editor" }
-                   [ H.div { className: "row"}
-                     [ H.div { className: "col-md-5" } [ H.div { ref, className: "html" } []]
-                     , H.div { className: "col-md-5" }
-                             [ H.div { className: "md" }
-                              [ H.textarea { className: "form-control"
-                                           , rows: 10
-                                           , on: {change: onChange ref editedMd}
-                                           } [ H.text $ fst editedMd ]
-                              ]
-                             ]
-                     ]
-                   ]
-
-    onChange :: forall e. R.Ref (Nullable Element) -> R.State String -> e -> Effect Unit
-    onChange ref (_ /\ setEditedMd) e = do
-      setEditedMd $ const value
-      where
-        value = R2.unsafeEventValue e

src/Gargantext/Components/Nodes/Corpus.purs

 module Gargantext.Components.Nodes.Corpus where
 
-import Prelude ((<<<))
-import Data.Argonaut (class DecodeJson, decodeJson, (.:), (.:?))
-import Data.Array (head)
+import Data.Argonaut (class DecodeJson, decodeJson, encodeJson)
+import Data.Argonaut.Parser (jsonParser)
+import Data.Array as A
+import Data.Either (Either(..))
 import Data.Maybe (Maybe(..))
+import Data.Tuple (Tuple(..), fst)
+import Data.Tuple.Nested ((/\))
 import DOM.Simple.Console (log2)
-import Effect.Aff (Aff, throwError)
+import Effect (Effect)
+import Effect.Aff (Aff, launchAff_, throwError)
+import Effect.Class (liftEffect)
 import Effect.Exception (error)
 import Reactix as R
 import Reactix.DOM.HTML as H
 
 import Gargantext.Prelude
+
 import Gargantext.Components.CodeEditor as CE
 import Gargantext.Components.Node (NodePoly(..), HyperdataList)
+import Gargantext.Components.Nodes.Corpus.Types
+import Gargantext.Data.Array as GDA
+import Gargantext.Hooks.Loader (useLoader)
 import Gargantext.Routes (SessionRoute(NodeAPI, Children))
-import Gargantext.Sessions (Session, get)
+import Gargantext.Sessions (Session, get, put)
 import Gargantext.Types (NodeType(..), AffTableResult)
+import Gargantext.Utils.Reactix as R2
+
+type Props = (
+    nodeId  :: Int
+  , session :: Session
+  )
 
-type Props = ( nodeId :: Int )
+type Reload = R.State Int
 
 corpusLayout :: Record Props -> R.Element
 corpusLayout props = R.createElement corpusLayoutCpt props []
 
 corpusLayoutCpt :: R.Component Props
-corpusLayoutCpt = R.hooksComponent "G.P.Corpus.corpusLayout" cpt
+corpusLayoutCpt = R.hooksComponent "G.C.N.C.corpusLayout" cpt
+  where
+    cpt {nodeId, session} _ = do
+      reload <- R.useState' 0
+
+      useLoader {nodeId, reload: fst reload, session} loadCorpusWithReload $
+        \corpus -> corpusLayoutView {corpus, nodeId, reload, session}
+
+type ViewProps = (
+    corpus  :: NodePoly Hyperdata
+  , reload  :: Reload
+  | Props
+  )
+
+-- We need FTFields with indices because it's the only way to identify the
+-- FTField element inside a component (there are no UUIDs and such)
+type Index = Int
+type FTFieldWithIndex = Tuple Index FTField
+
+corpusLayoutView :: Record ViewProps -> R.Element
+corpusLayoutView props = R.createElement corpusLayoutViewCpt props []
+
+corpusLayoutViewCpt :: R.Component ViewProps
+corpusLayoutViewCpt = R.hooksComponent "G.C.N.C.corpusLayoutView" cpt
+  where
+    cpt {corpus: (NodePoly {hyperdata: Hyperdata {fields}}), nodeId, reload, session} _ = do
+      let fieldsWithIndex = A.mapWithIndex (\idx -> \t -> Tuple idx t) fields
+      fieldsS <- R.useState' fieldsWithIndex
+
+      pure $ H.div {} [
+        H.div { className: "row" } [
+           H.div { className: "btn btn-default " <> (saveEnabled fieldsWithIndex fieldsS)
+                 , on: { click: onClickSave {fields: fieldsS, nodeId, reload, session} }
+                 } [
+              H.span { className: "glyphicon glyphicon-save" } [  ]
+              ]
+           ]
+        , H.div {} [ fieldsCodeEditor {nodeId, session, fields: fieldsS} ]
+        , H.div { className: "row" } [
+           H.div { className: "btn btn-default"
+                 , on: { click: onClickAdd fieldsS }
+                 } [
+              H.span { className: "glyphicon glyphicon-plus" } [  ]
+              ]
+           ]
+        ]
+
+    saveEnabled :: Array FTFieldWithIndex -> R.State (Array FTFieldWithIndex) -> String
+    saveEnabled fs (fsS /\ _) = if fs == fsS then "disabled" else "enabled"
+
+    onClickSave :: forall e. { fields :: R.State (Array FTFieldWithIndex)
+                             , nodeId :: Int
+                             , reload :: R.State Int
+                             , session :: Session } -> e -> Effect Unit
+    onClickSave {fields: (fieldsS /\ _), nodeId, reload: (_ /\ setReload), session} _ = do
+      log2 "[corpusLayoutViewCpt] onClickSave fieldsS" fieldsS
+      launchAff_ do
+        saveCorpus $ { hyperdata: Hyperdata {fields: (\(Tuple _ f) -> f) <$> fieldsS}
+                     , nodeId
+                     , session }
+        liftEffect $ setReload $ (+) 1
+
+    onClickAdd :: forall e. R.State (Array FTFieldWithIndex) -> e -> Effect Unit
+    onClickAdd (_ /\ setFieldsS) _ = do
+      setFieldsS $ \fieldsS -> A.snoc fieldsS $ Tuple (A.length fieldsS) defaultField
+
+type FieldsCodeEditorProps =
+  (
+    fields :: R.State (Array FTFieldWithIndex)
+    | LoadProps
+  )
+
+fieldsCodeEditor :: Record FieldsCodeEditorProps -> R.Element
+fieldsCodeEditor props = R.createElement fieldsCodeEditorCpt props []
+
+fieldsCodeEditorCpt :: R.Component FieldsCodeEditorProps
+fieldsCodeEditorCpt = R.hooksComponent "G.C.N.C.fieldsCodeEditorCpt" cpt
+  where
+    cpt {nodeId, fields: fS@(fields /\ _), session} _ = do
+      pure $ H.div {} $
+        (\(Tuple idx field) ->
+          fieldCodeEditorWrapper { canMoveDown: idx < (A.length fields - 1)
+                                 , canMoveUp: idx > 0
+                                 , field
+                                 , onChange: onChange fS idx
+                                 , onMoveDown: onMoveDown fS idx
+                                 , onMoveUp: onMoveUp fS idx
+                                 , onRemove: onRemove fS idx
+                                 , onRename: onRename fS idx
+                                 }) <$> fields
+
+    onChange :: R.State (Array FTFieldWithIndex) -> Index -> FieldType -> Effect Unit
+    onChange (_ /\ setFields) idx typ = do
+      setFields $ \fields ->
+        case A.modifyAt idx (\(Tuple _ (Field f)) -> Tuple idx (Field $ f { typ = typ })) fields of
+          Nothing -> fields
+          Just newFields -> newFields
+
+    onMoveDown :: R.State (Array FTFieldWithIndex) -> Index -> Unit -> Effect Unit
+    onMoveDown (fs /\ setFields) idx _ = do
+      setFields $ recomputeIndices <<< (GDA.swap idx (idx + 1))
+
+    onMoveUp :: R.State (Array FTFieldWithIndex) -> Index -> Unit -> Effect Unit
+    onMoveUp (_ /\ setFields) idx _ = do
+      setFields $ recomputeIndices <<< (GDA.swap idx (idx - 1))
+
+    onRemove :: R.State (Array FTFieldWithIndex) -> Index -> Unit -> Effect Unit
+    onRemove (_ /\ setFields) idx _ = do
+      setFields $ \fields ->
+        case A.deleteAt idx fields of
+          Nothing -> fields
+          Just newFields -> recomputeIndices newFields
+
+    onRename :: R.State (Array FTFieldWithIndex) -> Index -> String -> Effect Unit
+    onRename (_ /\ setFields) idx newName = do
+      setFields $ \fields ->
+        case A.modifyAt idx (\(Tuple _ (Field f)) -> Tuple idx (Field $ f { name = newName })) fields of
+          Nothing -> fields
+          Just newFields -> newFields
+
+    recomputeIndices :: Array FTFieldWithIndex -> Array FTFieldWithIndex
+    recomputeIndices = A.mapWithIndex $ \idx -> \(Tuple _ t) -> Tuple idx t
+
+type FieldCodeEditorProps =
+  (
+    canMoveDown :: Boolean
+  , canMoveUp :: Boolean
+  , field :: FTField
+  , onChange :: FieldType -> Effect Unit
+  , onMoveDown :: Unit -> Effect Unit
+  , onMoveUp :: Unit -> Effect Unit
+  , onRemove :: Unit -> Effect Unit
+  , onRename :: String -> Effect Unit
+  )
+
+fieldCodeEditorWrapper :: Record FieldCodeEditorProps -> R.Element
+fieldCodeEditorWrapper props = R.createElement fieldCodeEditorWrapperCpt props []
+
+fieldCodeEditorWrapperCpt :: R.Component FieldCodeEditorProps
+fieldCodeEditorWrapperCpt = R.hooksComponent "G.C.N.C.fieldCodeEditorWrapperCpt" cpt
+  where
+    cpt props@{canMoveDown, canMoveUp, field: Field {name, typ}, onMoveDown, onMoveUp, onRemove, onRename} _ = do
+      pure $ H.div { className: "row panel panel-default" } [
+        H.div { className: "panel-heading" } [
+          H.div { className: "code-editor-heading" } [
+              renameable {onRename, text: name}
+            , H.div { className: "buttons-right" } [
+                H.div { className: "btn btn-danger"
+                      , on: { click: \_ -> onRemove unit }
+                      } [
+                  H.span { className: "glyphicon glyphicon-trash" } [  ]
+                  ]
+                ]
+              , moveDownButton canMoveDown
+              , moveUpButton canMoveUp
+            ]
+         ]
+        , H.div { className: "panel-body" } [
+           fieldCodeEditor props
+           ]
+        ]
       where
-    cpt {nodeId} _ = do
-      pure $ H.div {}
-        [
-          CE.codeEditor {code, defaultCodeType: CE.Markdown, onChange}
-          --H.iframe { src: gargMd , width: "100%", height: "100%", style: {"border-style": "none"}} []
-        ]
-    --gargMd = "https://hackmd.iscpif.fr/g9Aah4iwQtCayIzsKQjA0Q#"
-    code = "# Hello world\n\n## subtitle\n\n- item 1\n- item 2\n\n1. num 1\n2. num 2\n\n[purescript link](https://purescript.org)"
-    onChange c = do
-      log2 "[corpusLayoutCpt] c" c
-
-newtype CorpusInfo =
-  CorpusInfo
-  { title        :: String
-  , desc         :: String
-  , query        :: String
-  , authors      :: String
-  , chart        :: (Maybe (Array Number))
-  , totalRecords :: Int }
-
-hyperdataDefault :: CorpusInfo
-hyperdataDefault =
-  CorpusInfo
-  { title : "Default title"
-  , desc  : " Default desc"
-  , query : " Default Query"
-  , authors : " Author(s): default"
-  , chart   : Nothing
-  , totalRecords : 0 }
-
-corpusInfoDefault :: NodePoly CorpusInfo
-corpusInfoDefault =
-  NodePoly
-  { id : 0
-  , typename : 0
-  , userId : 0
-  , parentId : 0
-  , name : "Default name"
-  , date  : " Default date"
-  , hyperdata : hyperdataDefault }
-
-instance decodeCorpusInfo :: DecodeJson CorpusInfo where
-  decodeJson json = do
-    obj <- decodeJson json
-    title <- obj .: "title"
-    desc  <- obj .: "desc"
-    query <- obj .: "query"
-    authors <- obj .: "authors"
-    chart   <- obj .:? "chart"
-    let totalRecords = 47361 -- TODO
-    pure $ CorpusInfo {title, desc, query, authors, chart, totalRecords}
-
-type CorpusData = { corpusId :: Int
-                  , corpusNode :: NodePoly CorpusInfo
-                  , defaultListId :: Int}
-
-loadCorpus :: { session :: Session, nodeId :: Int } -> Aff CorpusData
-loadCorpus {session, nodeId: listId} = do
+        moveDownButton false = H.div {} []
+        moveDownButton true =
+          H.div { className: "btn btn-default"
+                , on: { click: \_ -> onMoveDown unit }
+                } [
+            H.span { className: "glyphicon glyphicon-arrow-down" } [  ]
+            ]
+        moveUpButton false = H.div {} []
+        moveUpButton true =
+          H.div { className: "btn btn-default"
+                , on: { click: \_ -> onMoveUp unit }
+                } [
+            H.span { className: "glyphicon glyphicon-arrow-up" } [  ]
+            ]
+
+type RenameableProps =
+  (
+    onRename :: String -> Effect Unit
+  , text :: String
+  )
+
+renameable :: Record RenameableProps -> R.Element
+renameable props = R.createElement renameableCpt props []
+
+renameableCpt :: R.Component RenameableProps
+renameableCpt = R.hooksComponent "G.C.N.C.renameableCpt" cpt
+  where
+    cpt {onRename, text} _ = do
+      isEditing <- R.useState' false
+      state <- R.useState' text
+
+      pure $ H.div { className: "renameable" } [
+        textCpt isEditing onRename state
+      ]
+
+    textCpt :: R.State Boolean -> (String -> Effect Unit) -> R.State String -> R.Element
+    textCpt (false /\ setIsEditing) _ (text /\ _) = H.div {} [
+        H.span { className: "text" } [ H.text text ]
+      , H.span { className: "btn btn-default"
+               , on: { click: \_ -> setIsEditing $ const true } } [
+          H.span { className: "glyphicon glyphicon-pencil" } []
+        ]
+    ]
+    textCpt (true /\ setIsEditing) onRename (text /\ setText) = H.div {} [
+        H.input { defaultValue: text
+                , className: "form-control text"
+                , on: { change: \e -> setText $ const $ R2.unsafeEventValue e } }
+      , H.span { className: "btn btn-default"
+              , on: { click: \_ -> do
+                      setIsEditing $ const false
+                      onRename text
+                    } } [
+          H.span { className: "glyphicon glyphicon-save" } []
+        ]
+    ]
+
+fieldCodeEditor :: Record FieldCodeEditorProps -> R.Element
+fieldCodeEditor props = R.createElement fieldCodeEditorCpt props []
+
+fieldCodeEditorCpt :: R.Component FieldCodeEditorProps
+fieldCodeEditorCpt = R.hooksComponent "G.C.N.C.fieldCodeEditorCpt" cpt
+  where
+    cpt {field: Field {typ: typ@(Haskell {haskell})}, onChange} _ = do
+      pure $ CE.codeEditor {code: haskell, defaultCodeType: CE.Haskell, onChange: changeCode onChange typ}
+    cpt {field: Field {typ: typ@(JSON j)}, onChange} _ = do
+      pure $ CE.codeEditor {code, defaultCodeType: CE.JSON, onChange: changeCode onChange typ}
+      where
+        code = R2.stringify (encodeJson j) 2
+    cpt {field: Field {typ: typ@(Markdown {text})}, onChange} _ = do
+      pure $ CE.codeEditor {code: text, defaultCodeType: CE.Markdown, onChange: changeCode onChange typ}
+
+-- Perofrms the matrix of code type changes
+-- (FieldType -> Effect Unit) is the callback function for fields array
+-- FieldType is the current element that we will modify
+-- CE.CodeType is the editor code type (might have been the cause of the trigger)
+-- CE.Code is the editor code (might have been the cause of the trigger)
+changeCode :: (FieldType -> Effect Unit) -> FieldType -> CE.CodeType -> CE.Code -> Effect Unit
+changeCode onc (Haskell hs) CE.Haskell c = onc $ Haskell $ hs { haskell = c }
+changeCode onc (Haskell {haskell}) CE.JSON c = onc $ JSON $ defaultJSON' { desc = haskell }
+changeCode onc (Haskell {haskell}) CE.Markdown c = onc $ Markdown $ defaultMarkdown' { text = haskell }
+changeCode onc (JSON j@{desc}) CE.Haskell c = onc $ Haskell $ defaultHaskell' { haskell = haskell }
+  where
+    haskell = R2.stringify (encodeJson j) 2
+changeCode onc (JSON j) CE.JSON c = do
+  case jsonParser c of
+    Left err -> log2 "[fieldCodeEditor'] cannot parse json" c
+    Right j' -> case decodeJson j' of
+      Left err -> log2 "[fieldCodeEditor'] cannot decode json" j'
+      Right j'' -> onc $ JSON j''
+changeCode onc (JSON j) CE.Markdown c = onc $ Markdown $ defaultMarkdown' { text = text }
+  where
+    text = R2.stringify (encodeJson j) 2
+changeCode onc (Markdown md) CE.Haskell c = onc $ Haskell $ defaultHaskell' { haskell = c }
+changeCode onc (Markdown md) CE.JSON c = onc $ Markdown $ defaultMarkdown' { text = c }
+changeCode onc (Markdown md) CE.Markdown c = onc $ Markdown $ md { text = c }
+
+type LoadProps = (
+    nodeId  :: Int
+  , session :: Session
+  )
+
+loadCorpus' :: Record LoadProps -> Aff (NodePoly Hyperdata)
+loadCorpus' {nodeId, session} = get session $ NodeAPI Corpus (Just nodeId) ""
+
+-- Just to make reloading effective
+loadCorpusWithReload :: {reload :: Int  | LoadProps} -> Aff (NodePoly Hyperdata)
+loadCorpusWithReload {nodeId, session} = loadCorpus' {nodeId, session}
+
+type SaveProps = (
+  hyperdata :: Hyperdata
+  | LoadProps
+  )
+
+saveCorpus :: Record SaveProps -> Aff Unit
+saveCorpus {hyperdata, nodeId, session} = do
+  id_ <- (put session (NodeAPI Corpus (Just nodeId) "") hyperdata) :: Aff Int
+  pure unit
+
+loadCorpus :: Record LoadProps -> Aff CorpusData
+loadCorpus {nodeId, session} = do
   -- fetch corpus via lists parentId
   (NodePoly {parentId: corpusId} :: NodePoly {}) <- get session nodePolyRoute
   corpusNode     <-  get session $ corpusNodeRoute     corpusId ""
-  defaultListIds <- (get session $ defaultListIdsRoute corpusId) :: forall a. DecodeJson a => AffTableResult (NodePoly a)
-  case (head defaultListIds.docs :: Maybe (NodePoly HyperdataList)) of
+  defaultListIds <- (get session $ defaultListIdsRoute corpusId)
+                    :: forall a. DecodeJson a => AffTableResult (NodePoly a)
+  case (A.head defaultListIds.docs :: Maybe (NodePoly HyperdataList)) of
     Just (NodePoly { id: defaultListId }) ->
       pure {corpusId, corpusNode, defaultListId}
     Nothing ->
       throwError $ error "Missing default list"
   where
-    nodePolyRoute       = NodeAPI Corpus (Just listId) ""
+    nodePolyRoute       = NodeAPI Corpus (Just nodeId) ""
     corpusNodeRoute     = NodeAPI Corpus <<< Just
     defaultListIdsRoute = Children NodeList 0 1 Nothing <<< Just
+
+
+loadCorpusWithChild :: Record LoadProps -> Aff CorpusData
+loadCorpusWithChild {nodeId:childId, session} = do
+  -- fetch corpus via lists parentId
+  (NodePoly {parentId: corpusId} :: NodePoly {}) <- get session $ listNodeRoute childId ""
+  corpusNode     <-  get session $ corpusNodeRoute     corpusId ""
+  defaultListIds <- (get session $ defaultListIdsRoute corpusId)
+                    :: forall a. DecodeJson a => AffTableResult (NodePoly a)
+  case (A.head defaultListIds.docs :: Maybe (NodePoly HyperdataList)) of
+    Just (NodePoly { id: defaultListId }) ->
+      pure {corpusId, corpusNode, defaultListId}
+    Nothing ->
+      throwError $ error "Missing default list"
+  where
+    corpusNodeRoute     = NodeAPI Corpus <<< Just
+    listNodeRoute       = NodeAPI Node <<< Just
+    defaultListIdsRoute = Children NodeList 0 1 Nothing <<< Just
+

src/Gargantext/Components/Nodes/Corpus/Types.purs

+module Gargantext.Components.Nodes.Corpus.Types where
+
+import Data.Maybe (Maybe(..))
+import Data.Array (head)
+import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, (.:), (.:?), (:=), (~>), jsonEmptyObject)
+import Data.Either (Either(..))
+import Data.Generic.Rep (class Generic)
+import Data.Generic.Rep.Eq (genericEq)
+import Data.Maybe (Maybe)
+
+import Gargantext.Prelude
+
+import Gargantext.Components.Node (NodePoly)
+
+type Author = String
+type Description = String
+type Query = String
+type Tag = String
+type Title = String
+type HaskellCode = String
+type MarkdownText = String
+
+newtype Hyperdata =
+  Hyperdata
+  { fields :: Array 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
+  }
+type FTField = Field FieldType
+derive instance genericFTField :: Generic (Field FieldType) _
+instance eqFTField :: Eq (Field FieldType) where
+  eq = genericEq
+
+data FieldType =
+    Haskell {
+    haskell          :: HaskellCode
+  , tag              :: Tag
+  }
+  | JSON {
+    authors        :: Author
+  , desc           :: Description
+  , query          :: Query
+  , tag            :: Tag
+  , title          :: Title
+  }
+  | Markdown {
+    tag              :: Tag
+  , text             :: MarkdownText
+  }
+
+isJSON :: FieldType -> Boolean
+isJSON (JSON _) = true
+isJSON _        = false
+
+getCorpusInfo :: Array (Field FieldType) -> CorpusInfo
+getCorpusInfo as = case head as of
+  Just (Field {typ: JSON {authors, desc,query,title}}) -> CorpusInfo { title
+                                                                     , desc
+                                                                     , query
+                                                                     , authors
+                                                                     , chart:Nothing
+                                                                     , totalRecords:0
+                                                                     }
+  _                                -> CorpusInfo { title:"Empty"
+                                                 , desc:""
+                                                 , query:""
+                                                 , authors:""
+                                                 , chart:Nothing
+                                                 , totalRecords:0
+                                                 }
+
+
+derive instance genericFieldType :: Generic FieldType _
+instance eqFieldType :: Eq FieldType where
+  eq = genericEq
+instance decodeFTField :: DecodeJson (Field FieldType) where
+  decodeJson json = do
+    obj <- decodeJson json
+    name <- obj .: "name"
+    type_ <- obj .: "type"
+    data_ <- obj .: "data"
+    typ <- case type_ of
+      "Haskell" -> do
+        haskell <- data_ .: "haskell"
+        tag <- data_ .: "tag"
+        pure $ Haskell {haskell, tag}
+      "JSON" -> do
+        authors <- data_ .: "authors"
+        desc <- data_ .: "desc"
+        query <- data_ .: "query"
+        tag <- data_ .: "tag"
+        title <- data_ .: "title"
+        pure $ JSON {authors, desc, query, tag, title}
+      "Markdown" -> do
+        tag <- data_ .: "tag"
+        text <- data_ .: "text"
+        pure $ Markdown {tag, text}
+      _ -> Left $ "Unsupported 'type' " <> type_
+    pure $ Field {name, typ}
+instance encodeFTField :: EncodeJson (Field FieldType) where
+  encodeJson (Field {name, typ}) =
+       "data"  := typ
+    ~> "name"  := name
+    ~> "type"   := typ' typ
+    ~> jsonEmptyObject
+    where
+      typ' (Haskell _)  = "Haskell"
+      typ' (JSON _)     = "JSON"
+      typ' (Markdown _) = "Markdown"
+instance encodeFieldType :: EncodeJson FieldType where
+  encodeJson (Haskell {haskell}) =
+       "haskell" := haskell
+    ~> "tag"  := "HaskellField"
+    ~> jsonEmptyObject
+  encodeJson (JSON {authors, desc, query, tag, title}) =
+       "authors" := authors
+    ~> "desc"    := desc
+    ~> "query"   := query
+    ~> "tag"     := "JsonField"
+    ~> "title"   := title
+    ~> jsonEmptyObject
+  encodeJson (Markdown {text}) =
+       "tag"  := "MarkdownField"
+    ~> "text" := text
+    ~> jsonEmptyObject
+
+defaultHaskell :: FieldType
+defaultHaskell = Haskell defaultHaskell'
+defaultHaskell' = {
+    haskell: ""
+  , tag: "HaskellField"
+  }
+
+defaultJSON :: FieldType
+defaultJSON = JSON defaultJSON'
+defaultJSON' = {
+    authors: ""
+  , desc: ""
+  , query: ""
+  , tag: "JSONField"
+  , title: ""
+}
+
+defaultMarkdown :: FieldType
+defaultMarkdown = Markdown defaultMarkdown'
+defaultMarkdown' = {
+    tag: "MarkdownField"
+  , text: "# New file"
+  }
+
+defaultField :: FTField
+defaultField = Field {
+    name: "New file"
+  , typ: defaultMarkdown
+  }
+
+newtype CorpusInfo =
+  CorpusInfo
+  { title        :: String
+  , desc         :: String
+  , query        :: String
+  , authors      :: String
+  , chart        :: (Maybe (Array Number))
+  , totalRecords :: Int }
+
+instance decodeCorpusInfo :: DecodeJson CorpusInfo where
+  decodeJson json = do
+    obj <- decodeJson json
+    title <- obj .: "title"
+    desc  <- obj .: "desc"
+    query <- obj .: "query"
+    authors <- obj .: "authors"
+    chart   <- obj .:? "chart"
+    let totalRecords = 47361 -- TODO
+    pure $ CorpusInfo {title, desc, query, authors, chart, totalRecords}
+
+type CorpusData = { corpusId :: Int
+                  , corpusNode :: NodePoly Hyperdata -- CorpusInfo
+                  , defaultListId :: Int}

src/Gargantext/Components/Nodes/Lists.purs

 module Gargantext.Components.Nodes.Lists where
 
 import Reactix as R
---------------------------------------------------------
-import Gargantext.Prelude
-import Gargantext.Components.Nodes.Corpus (CorpusInfo(..), loadCorpus)
+------------------------------------------------------------------------
 import Gargantext.Components.Node (NodePoly(..))
+import Gargantext.Components.Nodes.Corpus (loadCorpusWithChild)
+import Gargantext.Components.Nodes.Corpus.Types (getCorpusInfo, CorpusInfo(..), Hyperdata(..))
+import Gargantext.Components.Nodes.Lists.Tabs as Tabs
 import Gargantext.Components.Table as Table
 import Gargantext.Hooks.Loader (useLoader)
-import Gargantext.Components.Nodes.Lists.Tabs as Tabs
+import Gargantext.Prelude
 import Gargantext.Sessions (Session)
-
+------------------------------------------------------------------------
 ------------------------------------------------------------------------
 
 type Props = ( session :: Session, nodeId :: Int )
@@ -21,12 +22,13 @@ listsLayoutCpt :: R.Component Props
 listsLayoutCpt = R.hooksComponent "G.P.Lists.listsLayout" cpt
   where
     cpt path@{session} _ =
-      useLoader path loadCorpus $
+      useLoader path loadCorpusWithChild $
         \corpusData@{corpusId, defaultListId, corpusNode: NodePoly poly} ->
-          let { name, date, hyperdata: CorpusInfo corpus } = poly
-              { desc, query, authors: user } = corpus in
+              let { name, date, hyperdata : Hyperdata h} = poly
+                  CorpusInfo {desc,query,authors} = getCorpusInfo h.fields
+           in
           R.fragment
           [ Table.tableHeaderLayout
-            { title: "Corpus " <> name, desc, query, user, date }
+            { title: "Corpus " <> name, desc, query, user:authors, date }
          , Tabs.tabs {session, corpusId, corpusData}]
 ------------------------------------------------------------------------

src/Gargantext/Components/Nodes/Lists/Tabs.purs

@@ -6,7 +6,7 @@ import Data.Tuple.Nested ((/\))
 import Reactix as R
 import Gargantext.Components.NgramsTable as NT
 import Gargantext.Components.Tab as Tab
-import Gargantext.Components.Nodes.Corpus (CorpusData)
+import Gargantext.Components.Nodes.Corpus.Types (CorpusData)
 import Gargantext.Components.Nodes.Corpus.Chart.Metrics (metrics)
 import Gargantext.Components.Nodes.Corpus.Chart.Pie  (pie, bar)
 import Gargantext.Components.Nodes.Corpus.Chart.Tree (tree)

src/Gargantext/Components/Nodes/Texts.purs

@@ -7,18 +7,19 @@ import Data.Maybe (Maybe(..))
 import Data.Tuple.Nested ((/\))
 import Reactix as R
 import Reactix.DOM.HTML as H
-
 --------------------------------------------------------
 import Gargantext.Components.DocsTable as DT
 import Gargantext.Components.Loader (loader)
 import Gargantext.Components.Node (NodePoly(..))
-import Gargantext.Components.Nodes.Corpus (CorpusData, CorpusInfo(..), loadCorpus)
+import Gargantext.Components.Nodes.Corpus (loadCorpusWithChild)
 import Gargantext.Components.Nodes.Corpus.Chart.Histo (histo)
+import Gargantext.Components.Nodes.Corpus.Types (CorpusData, Hyperdata(..), getCorpusInfo, CorpusInfo(..))
 import Gargantext.Components.Tab as Tab
 import Gargantext.Components.Table as Table
 import Gargantext.Ends (Frontends)
 import Gargantext.Sessions (Session)
 import Gargantext.Types (CTabNgramType(..), TabSubType(..), TabType(..))
+--------------------------------------------------------
 
 type Props = ( frontends :: Frontends, session :: Session, nodeId :: Int )
 
@@ -29,16 +30,16 @@ textsLayout props = R.createElement textsLayoutCpt props []
 textsLayoutCpt :: R.Component Props
 textsLayoutCpt = R.hooksComponent "G.C.Nodes.Texts.textsLayout" cpt where
   cpt {session,nodeId,frontends} _ = do
-    pure $ loader {session, nodeId} loadCorpus paint
+    pure $ loader {session, nodeId} loadCorpusWithChild paint
     where
       paint corpusData@{corpusId, corpusNode, defaultListId} =
         R.fragment [ Table.tableHeaderLayout headerProps, tabs' ]
         where
-          NodePoly { name, date, hyperdata: CorpusInfo corpus } = corpusNode
-          {desc, query, authors: user} = corpus
+          NodePoly { name, date, hyperdata: Hyperdata h } = corpusNode
+          CorpusInfo {desc,query,authors} = getCorpusInfo h.fields
           tabs' = tabs {session, corpusId, corpusData, frontends}
           title = "Corpus " <> name
-          headerProps = { title, desc, query, date, user }
+          headerProps = { title, desc, query, date, user:authors }
 
 data Mode = MoreLikeFav | MoreLikeTrash
 

src/Gargantext/Data/Array.purs

@@ -48,3 +48,13 @@ seqCatMaybes = seqMapMaybe identity
 -- | Seq misc tools
 seqConcatMap :: forall a b. (a -> Seq.Seq b) -> Seq.Seq a -> Seq.Seq b
 seqConcatMap = flip bind
+
+-- swap 2 array indices
+swap :: forall a. Int -> Int -> Array a -> Array a
+swap i j arr = DA.updateAtIndices updates arr
+  where
+    updates = case DA.index arr i of
+      Nothing -> []
+      Just iEl -> case DA.index arr j of
+        Nothing -> []
+        Just jEl -> [ Tuple i jEl, Tuple j iEl ]

src/Gargantext/Utils/HighlightJS.js

+'use strict';
+
+const hljs = require('highlightjs/highlight.pack.min.js');
+
+function highlightBlock(el) {
+    hljs.highlightBlock(el);
+}
+
+exports._highlightBlock = highlightBlock;

src/Gargantext/Utils/HighlightJS.purs

+module Gargantext.Utils.HighlightJS where
+
+import DOM.Simple (Element)
+import Effect (Effect)
+import Effect.Uncurried (EffectFn1, runEffectFn1)
+
+import Gargantext.Prelude
+
+highlightBlock :: Element -> Effect Unit
+highlightBlock el = runEffectFn1 _highlightBlock el
+
+foreign import _highlightBlock :: EffectFn1 Element Unit

src/index.html

@@ -11,6 +11,7 @@
         <link href="styles/bootstrap.min.css" rel="stylesheet">
         <link rel="stylesheet" type="text/css" href="styles/context-menu.css"/>
         <link rel="stylesheet" type="text/css" href="styles/menu.css"/>
+        <link rel="stylesheet" type="text/css" href="styles/highlightjs-solarized-light.css"/>
         <link href="styles/Graph.css" rel="stylesheet" type="text/css" />
         <link href="styles/Login.css" rel="stylesheet" type="text/css" />
         <link href="styles/CodeEditor.css" rel="stylesheet" type="text/css" />

test/Gargantext/Data/Spec.purs

+module Gargantext.Data.Spec where
+
+import Prelude
+import Data.Array (index)
+import Data.Foldable (all)
+import Data.Maybe (Maybe(..), isJust)
+import Data.String (drop, stripPrefix, Pattern(..))
+import Data.Tuple (Tuple(..))
+import Test.Spec (Spec, describe, it)
+import Test.Spec.Assertions (shouldEqual)
+import Test.Spec.QuickCheck (quickCheck')
+
+import Gargantext.Data.Array as GDA
+
+spec :: Spec Unit
+spec =
+  describe "G.D.Array" do
+    it "swap works" do
+      GDA.swap 1 0 [0, 1, 2] `shouldEqual` [1, 0, 2]
+      GDA.swap 1 2 [0, 1, 2] `shouldEqual` [0, 2, 1]