Corpus.purs 15.8 KB
Newer Older
1
module Gargantext.Components.Nodes.Corpus where
2

3 4
import Data.Argonaut (class DecodeJson, decodeJson, encodeJson)
import Data.Argonaut.Parser (jsonParser)
5
import Data.Array as A
6
import Data.Either (Either(..))
7
import Data.List as List
8
import Data.Maybe (Maybe(..))
9
import Data.Tuple (Tuple(..), fst, snd)
10
import Data.Tuple.Nested ((/\))
11
import DOM.Simple.Console (log2)
12
import Effect (Effect)
13 14
import Effect.Aff (Aff, launchAff_, throwError)
import Effect.Class (liftEffect)
15
import Effect.Exception (error)
16
import Reactix as R
17
import Reactix.DOM.HTML as H
18

19
import Gargantext.Prelude
20

21
import Gargantext.Components.CodeEditor as CE
22
import Gargantext.Components.Node (NodePoly(..), HyperdataList)
23
import Gargantext.Components.Nodes.Corpus.Types (CorpusData, FTField, Field(..), FieldType(..), Hash, Hyperdata(..), defaultField, defaultHaskell', defaultJSON', defaultMarkdown')
24
import Gargantext.Data.Array as GDA
25
import Gargantext.Hooks.Loader (useLoader)
26
import Gargantext.Routes (SessionRoute(NodeAPI, Children))
27
import Gargantext.Sessions (Session, get, put)
28
import Gargantext.Types (NodeType(..), AffTableResult)
29
import Gargantext.Utils.Crypto as GUC
30
import Gargantext.Utils.Reactix as R2
Nicolas Pouillard's avatar
Nicolas Pouillard committed
31

32 33 34 35
type Props = (
    nodeId  :: Int
  , session :: Session
  )
36

37 38
type Reload = R.State Int

39 40 41 42
corpusLayout :: Record Props -> R.Element
corpusLayout props = R.createElement corpusLayoutCpt props []

corpusLayoutCpt :: R.Component Props
43 44
corpusLayoutCpt = R.hooksComponent "G.C.N.C.corpusLayout" cpt
  where
45 46 47 48 49
    cpt {nodeId, session} _ = do
      reload <- R.useState' 0

      useLoader {nodeId, reload: fst reload, session} loadCorpusWithReload $
        \corpus -> corpusLayoutView {corpus, nodeId, reload, session}
50 51

type ViewProps = (
52
    corpus  :: NodePoly Hyperdata
53
  , reload  :: Reload
54 55 56
  | Props
  )

57 58
-- 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)
59 60
type Index = Int
type FTFieldWithIndex = Tuple Index FTField
61
type FTFieldsWithIndex = List.List FTFieldWithIndex
62

63 64 65 66 67
corpusLayoutView :: Record ViewProps -> R.Element
corpusLayoutView props = R.createElement corpusLayoutViewCpt props []

corpusLayoutViewCpt :: R.Component ViewProps
corpusLayoutViewCpt = R.hooksComponent "G.C.N.C.corpusLayoutView" cpt
68
  where
69
    cpt {corpus: (NodePoly {hyperdata: Hyperdata {fields}}), nodeId, reload, session} _ = do
70
      let fieldsWithIndex = List.mapWithIndex (\idx -> \t -> Tuple idx t) fields
71
      fieldsS <- R.useState' fieldsWithIndex
72 73 74 75 76 77 78 79 80
      fieldsRef <- R.useRef fields

      -- handle props change of fields
      R.useEffect1' fields $ do
        if R.readRef fieldsRef == fields then
          pure unit
        else do
          R.setRef fieldsRef fields
          snd fieldsS $ const fieldsWithIndex
81 82

      pure $ H.div {} [
83 84 85 86
        H.div { className: "row" } [
           H.div { className: "btn btn-default " <> (saveEnabled fieldsWithIndex fieldsS)
                 , on: { click: onClickSave {fields: fieldsS, nodeId, reload, session} }
                 } [
87
              H.span { className: "glyphicon glyphicon-floppy-disk" } [  ]
88 89
              ]
           ]
90 91 92
        , H.div {} [ fieldsCodeEditor { fields: fieldsS
                                      , nodeId
                                      , session } ]
93
        , H.div { className: "row" } [
94 95 96
           H.div { className: "btn btn-default"
                 , on: { click: onClickAdd fieldsS }
                 } [
97
              H.span { className: "glyphicon glyphicon-plus" } [  ]
98 99
              ]
           ]
100
        ]
101

102
    saveEnabled :: FTFieldsWithIndex -> R.State FTFieldsWithIndex -> String
103 104
    saveEnabled fs (fsS /\ _) = if fs == fsS then "disabled" else "enabled"

105
    onClickSave :: forall e. { fields :: R.State FTFieldsWithIndex
106
                             , nodeId :: Int
107
                             , reload :: R.State Int
108
                             , session :: Session } -> e -> Effect Unit
109
    onClickSave {fields: (fieldsS /\ _), nodeId, reload: (_ /\ setReload), session} _ = do
110 111 112 113 114
      log2 "[corpusLayoutViewCpt] onClickSave fieldsS" fieldsS
      launchAff_ do
        saveCorpus $ { hyperdata: Hyperdata {fields: (\(Tuple _ f) -> f) <$> fieldsS}
                     , nodeId
                     , session }
115
        liftEffect $ setReload $ (+) 1
116

117
    onClickAdd :: forall e. R.State FTFieldsWithIndex -> e -> Effect Unit
118
    onClickAdd (_ /\ setFieldsS) _ = do
119
      setFieldsS $ \fieldsS -> List.snoc fieldsS $ Tuple (List.length fieldsS) defaultField
120 121 122

type FieldsCodeEditorProps =
  (
123
    fields :: R.State FTFieldsWithIndex
124 125 126 127 128 129 130 131 132
    | 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
133
    cpt {nodeId, fields: fS@(fields /\ _), session} _ = do
134 135 136
      masterKey <- R.useState' 0

      pure $ H.div {} $ List.toUnfoldable (editors masterKey)
137
      where
138
        editors masterKey =
139
          (\(Tuple idx field) ->
140 141 142 143 144 145 146 147 148 149
            fieldCodeEditorWrapper { canMoveDown: idx < (List.length fields - 1)
                                   , canMoveUp: idx > 0
                                   , field
                                   , key: (show $ fst masterKey) <> "-" <> (show idx)
                                   , onChange: onChange fS idx
                                   , onMoveDown: onMoveDown masterKey fS idx
                                   , onMoveUp: onMoveUp masterKey fS idx
                                   , onRemove: onRemove fS idx
                                   , onRename: onRename fS idx
                                   }) <$> fields
150 151

    onChange :: R.State FTFieldsWithIndex -> Index -> FieldType -> Effect Unit
152 153
    onChange (_ /\ setFields) idx typ = do
      setFields $ \fields ->
154
        case List.modifyAt idx (\(Tuple _ (Field f)) -> Tuple idx (Field $ f { typ = typ })) fields of
155 156 157
          Nothing -> fields
          Just newFields -> newFields

158 159 160
    onMoveDown :: R.State Int -> R.State FTFieldsWithIndex -> Index -> Unit -> Effect Unit
    onMoveDown (_ /\ setMasterKey) (fs /\ setFields) idx _ = do
      setMasterKey $ (+) 1
161
      setFields $ recomputeIndices <<< (GDA.swapList idx (idx + 1))
162

163 164 165
    onMoveUp :: R.State Int -> R.State FTFieldsWithIndex -> Index -> Unit -> Effect Unit
    onMoveUp (_ /\ setMasterKey) (_ /\ setFields) idx _ = do
      setMasterKey $ (+) 1
166
      setFields $ recomputeIndices <<< (GDA.swapList idx (idx - 1))
167

168
    onRemove :: R.State FTFieldsWithIndex -> Index -> Unit -> Effect Unit
169 170
    onRemove (_ /\ setFields) idx _ = do
      setFields $ \fields ->
171
        case List.deleteAt idx fields of
172
          Nothing -> fields
173
          Just newFields -> recomputeIndices newFields
174

175
    onRename :: R.State FTFieldsWithIndex -> Index -> String -> Effect Unit
176 177
    onRename (_ /\ setFields) idx newName = do
      setFields $ \fields ->
178
        case List.modifyAt idx (\(Tuple _ (Field f)) -> Tuple idx (Field $ f { name = newName })) fields of
179 180 181
          Nothing -> fields
          Just newFields -> newFields

182 183
    recomputeIndices :: FTFieldsWithIndex -> FTFieldsWithIndex
    recomputeIndices = List.mapWithIndex $ \idx -> \(Tuple _ t) -> Tuple idx t
184

185 186 187
hash :: FTFieldWithIndex -> Hash
hash (Tuple idx f) = GUC.md5 $ "--idx--" <> (show idx) <> "--field--" <> (show f)

188 189
type FieldCodeEditorProps =
  (
190 191 192
    canMoveDown :: Boolean
  , canMoveUp :: Boolean
  , field :: FTField
193
  , key :: String
194
  , onChange :: FieldType -> Effect Unit
195 196
  , onMoveDown :: Unit -> Effect Unit
  , onMoveUp :: Unit -> Effect Unit
197
  , onRemove :: Unit -> Effect Unit
198
  , onRename :: String -> Effect Unit
199 200 201 202 203 204 205
  )

fieldCodeEditorWrapper :: Record FieldCodeEditorProps -> R.Element
fieldCodeEditorWrapper props = R.createElement fieldCodeEditorWrapperCpt props []

fieldCodeEditorWrapperCpt :: R.Component FieldCodeEditorProps
fieldCodeEditorWrapperCpt = R.hooksComponent "G.C.N.C.fieldCodeEditorWrapperCpt" cpt
206
  where
207 208
    cpt props@{canMoveDown, canMoveUp, field: Field {name, typ}, onMoveDown, onMoveUp, onRemove, onRename} _ = do
      pure $ H.div { className: "row panel panel-default" } [
209
        H.div { className: "panel-heading" } [
210 211 212 213 214 215 216 217 218
          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" } [  ]
                  ]
                ]
219 220
              , moveDownButton canMoveDown
              , moveUpButton canMoveUp
221 222
            ]
         ]
223 224 225 226
        , H.div { className: "panel-body" } [
           fieldCodeEditor props
           ]
        ]
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
      where
        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" } [  ]
            ]
242

243 244 245 246 247 248 249 250 251 252 253 254 255 256 257
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
258 259 260 261 262 263 264 265 266
      textRef <- R.useRef text

      -- handle props change of text
      R.useEffect1' text $ do
        if R.readRef textRef == text then
          pure unit
        else do
          R.setRef textRef text
          snd state $ const text
267 268

      pure $ H.div { className: "renameable" } [
269
        renameableText {isEditing, onRename, state}
270
      ]
271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291

type RenameableTextProps =
  (
    isEditing :: R.State Boolean
  , onRename :: String -> Effect Unit
  , state :: R.State String
  )

renameableText :: Record RenameableTextProps -> R.Element
renameableText props = R.createElement renameableTextCpt props []

renameableTextCpt :: R.Component RenameableTextProps
renameableTextCpt = R.hooksComponent "G.C.N.C.renameableTextCpt" cpt
  where
    cpt {isEditing: (false /\ setIsEditing), state: (text /\ _)} _ = do
      pure $ 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" } []
           ]
292
        ]
293 294 295 296 297 298 299 300 301 302 303 304
    cpt {isEditing: (true /\ setIsEditing), onRename, state: (text /\ setText)} _ = do
      pure $ 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-floppy-disk" } []
           ]
305 306
        ]

307 308 309 310 311
fieldCodeEditor :: Record FieldCodeEditorProps -> R.Element
fieldCodeEditor props = R.createElement fieldCodeEditorCpt props []

fieldCodeEditorCpt :: R.Component FieldCodeEditorProps
fieldCodeEditorCpt = R.hooksComponent "G.C.N.C.fieldCodeEditorCpt" cpt
312
  where
313 314 315 316
    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}
317 318
      where
        code = R2.stringify (encodeJson j) 2
319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345
    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 }
346

347 348 349 350
type LoadProps = (
    nodeId  :: Int
  , session :: Session
  )
351

352
loadCorpus' :: Record LoadProps -> Aff (NodePoly Hyperdata)
353
loadCorpus' {nodeId, session} = get session $ NodeAPI Corpus (Just nodeId) ""
354

355 356
-- Just to make reloading effective
loadCorpusWithReload :: {reload :: Int  | LoadProps} -> Aff (NodePoly Hyperdata)
357
loadCorpusWithReload {nodeId, session} = loadCorpus' {nodeId, session}
358

359 360 361 362 363 364
type SaveProps = (
  hyperdata :: Hyperdata
  | LoadProps
  )

saveCorpus :: Record SaveProps -> Aff Unit
365 366 367
saveCorpus {hyperdata, nodeId, session} = do
  id_ <- (put session (NodeAPI Corpus (Just nodeId) "") hyperdata) :: Aff Int
  pure unit
368

369 370
loadCorpus :: Record LoadProps -> Aff CorpusData
loadCorpus {nodeId, session} = do
371 372
  -- fetch corpus via lists parentId
  (NodePoly {parentId: corpusId} :: NodePoly {}) <- get session nodePolyRoute
373 374 375
  corpusNode     <-  get session $ corpusNodeRoute     corpusId ""
  defaultListIds <- (get session $ defaultListIdsRoute corpusId)
                    :: forall a. DecodeJson a => AffTableResult (NodePoly a)
376
  case (A.head defaultListIds.docs :: Maybe (NodePoly HyperdataList)) of
377 378 379 380 381
    Just (NodePoly { id: defaultListId }) ->
      pure {corpusId, corpusNode, defaultListId}
    Nothing ->
      throwError $ error "Missing default list"
  where
382
    nodePolyRoute       = NodeAPI Corpus (Just nodeId) ""
383 384
    corpusNodeRoute     = NodeAPI Corpus <<< Just
    defaultListIdsRoute = Children NodeList 0 1 Nothing <<< Just
385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403


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