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

3
import Data.Array as A
4
import Data.Either (Either(..))
5
import Data.Eq.Generic (genericEq)
6
import Data.Generic.Rep (class Generic)
7
import Data.List as List
8
import Data.Maybe (Maybe(..), fromMaybe)
9
import Data.Show.Generic (genericShow)
10
import Effect (Effect)
11
import Effect.Aff (throwError)
12
import Effect.Exception (error)
13
import Gargantext.Components.App.Data (Boxes)
14
import Gargantext.Components.CodeEditor as CE
15
import Gargantext.Components.FolderView as FV
16
import Gargantext.Components.InputWithEnter (inputWithEnter)
17
import Gargantext.Components.Node (NodePoly(..), HyperdataList)
18 19 20
import Gargantext.Components.Nodes.Corpus.Types (CorpusData, Hyperdata)
import Gargantext.Components.Nodes.Types (FTField, FTFieldWithIndex, FTFieldsWithIndex(..), Field(..), FieldType(..), Hash, Index, defaultHaskell', defaultJSON', defaultMarkdown', defaultPython')
import Gargantext.Components.TileMenu (tileMenu)
21
import Gargantext.Config.REST (RESTError(..), AffRESTError)
22
import Gargantext.Data.Array as GDA
23
import Gargantext.Prelude (class Eq, class Show, Unit, bind, discard, pure, show, unit, ($), (<>), const, (<<<), (+), (==), (-), (<), (>), (<$>))
24
import Gargantext.Routes (SessionRoute(Children, NodeAPI))
25
import Gargantext.Routes as GR
26
import Gargantext.Sessions (Session, get, put, sessionId)
27
import Gargantext.Types (AffETableResult, NodeType(..), ID)
28
import Gargantext.Utils.Crypto as Crypto
29
import Gargantext.Utils.Reactix as R2
30
import Gargantext.Utils.Toestand as T2
31 32 33 34
import Reactix as R
import Reactix.DOM.HTML as H
import Simple.JSON as JSON
import Toestand as T
Nicolas Pouillard's avatar
Nicolas Pouillard committed
35

James Laver's avatar
James Laver committed
36 37
here :: R2.Here
here = R2.here "Gargantext.Components.Nodes.Corpus"
38

39
type Props =
40
  ( boxes   :: Boxes
41
  , nodeId  :: ID
42
  , session :: Session )
43

James Laver's avatar
James Laver committed
44
corpusLayout :: R2.Leaf Props
45
corpusLayout = R2.leafComponent corpusLayoutCpt
46
corpusLayoutCpt :: R.Component Props
Karen Konou's avatar
Karen Konou committed
47
corpusLayoutCpt = here.component "corpusLayout" cpt where
48 49
  cpt { boxes, nodeId, session } _ = do
    pure $ corpusLayoutMain { boxes, key, nodeId, session }
50 51
      where
        key = show (sessionId session) <> "-" <> show nodeId
Karen Konou's avatar
Karen Konou committed
52 53

type KeyProps =
54
  ( boxes   :: Boxes
Karen Konou's avatar
Karen Konou committed
55
  , key     :: String
56
  , nodeId  :: ID
Karen Konou's avatar
Karen Konou committed
57 58 59 60
  , session :: Session
  )

corpusLayoutMain :: R2.Leaf KeyProps
61
corpusLayoutMain = R2.leafComponent corpusLayoutMainCpt
Karen Konou's avatar
Karen Konou committed
62 63
corpusLayoutMainCpt :: R.Component KeyProps
corpusLayoutMainCpt = here.component "corpusLayoutMain" cpt
64
  where
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
    cpt { boxes, nodeId, session } _ = do
      -- Computed
      corpusCodeRoute <- pure $ const do
        pure $ GR.CorpusCode (sessionId session) nodeId
      -- Render
      pure $

        H.div {}
        [
          tileMenu
          { boxes
          , currentTile: Just corpusCodeRoute
          , xTile: Just corpusCodeRoute
          , yTile: Just corpusCodeRoute
          }
          [
            H.button
            { className: "btn btn-primary" }
            [
              H.i { className: "fa fa-code" } []
85 86
            ]
          ]
87 88 89 90
        ,
          H.hr {}
        ,
          FV.folderView
91 92 93 94 95
            { backFolder: true
            , boxes
            , nodeId
            , session
            }
96
        ]
97

98
-----------------------------------
99

Karen Konou's avatar
Karen Konou committed
100

101 102
type FieldsCodeEditorProps =
  (
103
    fields :: T.Box FTFieldsWithIndex
104 105 106
    | LoadProps
  )

107
fieldsCodeEditor :: R2.Component FieldsCodeEditorProps
108 109
fieldsCodeEditor = R.createElement fieldsCodeEditorCpt
fieldsCodeEditorCpt :: R.Component FieldsCodeEditorProps
James Laver's avatar
James Laver committed
110
fieldsCodeEditorCpt = here.component "fieldsCodeEditorCpt" cpt
111
  where
112
    cpt { fields } _ = do
113
      (FTFieldsWithIndex fields') <- T.useLive T.unequal fields
114 115
      masterKey <- T.useBox T2.newReload
      masterKey' <- T.useLive T.unequal masterKey
116

117
      let editorsMap { idx, ftField } =
118
            fieldCodeEditorWrapper { canMoveDown: idx < (List.length fields' - 1)
119
                                   , canMoveUp: idx > 0
120
                                   , field: ftField
121
                                   , key: (show masterKey') <> "-" <> (show idx)
122 123 124 125 126 127 128 129 130 131 132
                                   , onChange: onChange idx
                                   , onMoveDown: onMoveDown masterKey idx
                                   , onMoveUp: onMoveUp masterKey idx
                                   , onRemove: onRemove idx
                                   , onRename: onRename idx
                                   }

      pure $ H.div {} $ List.toUnfoldable (editorsMap <$> fields')
      where
        onChange :: Index -> FieldType -> Effect Unit
        onChange idx typ = do
133 134 135
          T.modify_ (\(FTFieldsWithIndex fs) ->
            FTFieldsWithIndex $ fromMaybe fs $
              List.modifyAt idx (\{ ftField: Field f} -> { idx, ftField: Field $ f { typ = typ } }) fs) fields
136 137 138 139

        onMoveDown :: T2.ReloadS -> Index -> Unit -> Effect Unit
        onMoveDown masterKey idx _ = do
          T2.reload masterKey
140
          T.modify_ (\(FTFieldsWithIndex fs) -> recomputeIndices $ FTFieldsWithIndex $ GDA.swapList idx (idx + 1) fs) fields
141 142 143 144

        onMoveUp :: T2.ReloadS -> Index -> Unit -> Effect Unit
        onMoveUp masterKey idx _ = do
          T2.reload masterKey
145
          T.modify_ (\(FTFieldsWithIndex fs) -> recomputeIndices $ FTFieldsWithIndex $ GDA.swapList idx (idx - 1) fs) fields
146 147 148

        onRemove :: Index -> Unit -> Effect Unit
        onRemove idx _ = do
149
          T.modify_ (\(FTFieldsWithIndex fs) -> FTFieldsWithIndex $ fromMaybe fs $ List.deleteAt idx fs) fields
150 151 152

        onRename :: Index -> String -> Effect Unit
        onRename idx newName = do
153 154 155
          T.modify_ (\(FTFieldsWithIndex fs) ->
            FTFieldsWithIndex $ fromMaybe fs $
              List.modifyAt idx (\{ ftField: Field f } -> { idx, ftField: Field $ f { name = newName } }) fs) fields
156

157
    recomputeIndices :: FTFieldsWithIndex -> FTFieldsWithIndex
158
    recomputeIndices (FTFieldsWithIndex lst) = FTFieldsWithIndex $ List.mapWithIndex (\idx -> \{ ftField } -> { idx, ftField }) lst
159

160
hash :: FTFieldWithIndex -> Hash
161
hash { idx, ftField } = Crypto.hash $ "--idx--" <> (show idx) <> "--field--" <> (show ftField)
162

163 164
type FieldCodeEditorProps =
  (
165
    canMoveDown :: Boolean
166 167 168 169 170 171 172 173
  , canMoveUp   :: Boolean
  , field       :: FTField
  , key         :: String
  , onChange    :: FieldType -> Effect Unit
  , onMoveDown  :: Unit -> Effect Unit
  , onMoveUp    :: Unit -> Effect Unit
  , onRemove    :: Unit -> Effect Unit
  , onRename    :: String -> Effect Unit
174 175 176 177
  )

fieldCodeEditorWrapper :: Record FieldCodeEditorProps -> R.Element
fieldCodeEditorWrapper props = R.createElement fieldCodeEditorWrapperCpt props []
178
fieldCodeEditorWrapperCpt :: R.Component FieldCodeEditorProps
James Laver's avatar
James Laver committed
179
fieldCodeEditorWrapperCpt = here.component "fieldCodeEditorWrapperCpt" cpt
180
  where
181 182
    cpt props@{canMoveDown, canMoveUp, field: Field { name }, onMoveDown, onMoveUp, onRemove, onRename} _ = do
      pure $ H.div { className: "card mb-3" } [
183
        H.div { className: "card-header" } [
184 185
          H.div { className: "code-editor-heading row no-gutters justify-content-between" } [
              H.div { className: "col-5" } [
186 187 188 189 190 191 192 193
                 inputWithEnter { onBlur: onRename
                                , onEnter: \_ -> pure unit
                                , onValueChanged: onRename
                                , autoFocus: false
                                , className: "form-control"
                                , defaultValue: name
                                , placeholder: "Enter file name"
                                , type: "text" }
194
              ]
195 196
            , H.div { className: "d-flex flex-column" } ([
                H.div { className: "btn btn-danger mb-1"
197 198
                      , on: { click: \_ -> onRemove unit }
                      } [
199
                  H.span { className: "fa fa-trash" } [  ]
200
                  ]
201
              ] <> moveButtons)
202 203
            ]
         ]
204
        , H.div { className: "card-body" } [
205 206 207
           fieldCodeEditor props
           ]
        ]
208
      where
209 210 211
        moveButtons = [] <> (if canMoveDown then [moveDownButton] else [])
                         <> (if canMoveUp then [moveUpButton] else [])
        moveDownButton =
212
          H.div { className: "btn btn-primary"
213 214
                , on: { click: \_ -> onMoveDown unit }
                } [
215
            H.span { className: "fa fa-arrow-down" } [  ]
216
            ]
217
        moveUpButton =
218
          H.div { className: "btn btn-primary"
219 220
                , on: { click: \_ -> onMoveUp unit }
                } [
221
            H.span { className: "fa fa-arrow-up" } [  ]
222
            ]
223

224 225 226 227 228 229 230 231
type RenameableProps =
  (
    onRename :: String -> Effect Unit
  , text :: String
  )

renameable :: Record RenameableProps -> R.Element
renameable props = R.createElement renameableCpt props []
232
renameableCpt :: R.Component RenameableProps
James Laver's avatar
James Laver committed
233
renameableCpt = here.component "renameableCpt" cpt
234
  where
235
    cpt {onRename, text} _ = do
236 237
      isEditing <- T.useBox false
      state <- T.useBox text
238 239 240 241 242 243 244 245
      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
246
          T.write_ text state
247 248

      pure $ H.div { className: "renameable" } [
249
        renameableText { isEditing, onRename, state }
250
      ]
251 252 253

type RenameableTextProps =
  (
254 255 256
    isEditing :: T.Box Boolean
  , onRename  :: String -> Effect Unit
  , state     :: T.Box String
257 258 259 260
  )

renameableText :: Record RenameableTextProps -> R.Element
renameableText props = R.createElement renameableTextCpt props []
261
renameableTextCpt :: R.Component RenameableTextProps
James Laver's avatar
James Laver committed
262
renameableTextCpt = here.component "renameableTextCpt" cpt
263
  where
264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295
    cpt { isEditing, onRename, state } _ = do
      isEditing' <- T.useLive T.unequal isEditing
      state' <- T.useLive T.unequal state

      pure $ if isEditing' then
              H.div { className: "input-group" }
                [ inputWithEnter {
                    autoFocus: false
                  , className: "form-control text"
                  , defaultValue: state'
                  , onBlur: \st -> T.write_ st state
                  , onEnter: submit state'
                  , onValueChanged: \st -> T.write_ st state
                  , placeholder: ""
                  , type: "text"
                  }
                , H.div { className: "btn input-group-append"
                        , on: { click: submit state' } }
                  [ H.span { className: "fa fa-floppy-o" } []
                  ]
                ]
             else
               H.div { className: "input-group" }
               [ H.input { className: "form-control"
                         , defaultValue: state'
                         , disabled: 1
                         , type: "text" }
               , H.div { className: "btn input-group-append"
                       , on: { click: \_ -> T.write_ true isEditing } }
                 [ H.span { className: "fa fa-pencil" } []
                 ]
               ]
296
      where
297 298
        submit text _ = do
          T.write_ false isEditing
299
          onRename text
300

301 302
fieldCodeEditor :: Record FieldCodeEditorProps -> R.Element
fieldCodeEditor props = R.createElement fieldCodeEditorCpt props []
303
fieldCodeEditorCpt :: R.Component FieldCodeEditorProps
James Laver's avatar
James Laver committed
304
fieldCodeEditorCpt = here.component "fieldCodeEditorCpt" cpt
305
  where
306 307
    cpt {field: Field {typ: typ@(Haskell {haskell})}, onChange} _ = do
      pure $ CE.codeEditor {code: haskell, defaultCodeType: CE.Haskell, onChange: changeCode onChange typ}
308 309 310 311

    cpt {field: Field {typ: typ@(Python {python})}, onChange} _ = do
      pure $ CE.codeEditor {code: python, defaultCodeType: CE.Python, onChange: changeCode onChange typ}

312 313
    cpt {field: Field {typ: typ@(JSON j)}, onChange} _ = do
      pure $ CE.codeEditor {code, defaultCodeType: CE.JSON, onChange: changeCode onChange typ}
314
      where
315
        code = R2.stringify (JSON.writeImpl j) 2
316

317 318 319
    cpt {field: Field {typ: typ@(Markdown {text})}, onChange} _ = do
      pure $ CE.codeEditor {code: text, defaultCodeType: CE.Markdown, onChange: changeCode onChange typ}

320
-- Performs the matrix of code type changes
321 322 323 324 325
-- (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
326
changeCode onc (Haskell hs)        CE.Haskell  c = onc $ Haskell $ hs { haskell = c }
327 328 329
changeCode onc (Haskell _)         CE.Python   c = onc $ Python   $ defaultPython'   { python  = c }
changeCode onc (Haskell {haskell}) CE.JSON     _ = onc $ JSON     $ defaultJSON'     { desc = haskell }
changeCode onc (Haskell {haskell}) CE.Markdown _ = onc $ Markdown $ defaultMarkdown' { text = haskell }
330 331

changeCode onc (Python hs)       CE.Python   c = onc $ Python  $ hs { python  = c }
332 333 334
changeCode onc (Python _)        CE.Haskell  c = onc $ Haskell $ defaultHaskell' { haskell = c }
changeCode onc (Python {python}) CE.JSON     _ = onc $ JSON     $ defaultJSON' { desc = python }
changeCode onc (Python {python}) CE.Markdown _ = onc $ Markdown $ defaultMarkdown' { text = python }
335

336 337 338
changeCode onc (Markdown _)  CE.Haskell  c = onc $ Haskell  $ defaultHaskell'  { haskell = c }
changeCode onc (Markdown _)  CE.Python   c = onc $ Python   $ defaultPython'   { python  = c }
changeCode onc (Markdown _)  CE.JSON     c = onc $ Markdown $ defaultMarkdown' { text    = c }
339 340
changeCode onc (Markdown md) CE.Markdown c = onc $ Markdown $ md               { text    = c }

341
changeCode onc (JSON j) CE.Haskell _ = onc $ Haskell $ defaultHaskell' { haskell = haskell }
342
  where
343
    haskell = R2.stringify (JSON.writeImpl j) 2
344
changeCode onc (JSON j) CE.Python _ = onc $ Python $ defaultPython' { python = toCode }
345
  where
346 347 348
    toCode = R2.stringify (JSON.writeImpl j) 2
changeCode onc _ CE.JSON c = do
  case JSON.readJSON c of
349
    Left err -> here.log2 "[fieldCodeEditor'] cannot parse json" c  -- TODO Refactor?
350 351
    Right j' -> onc $ JSON j'
  -- case jsonParser c of
352
  --   Left err -> here.log2 "[fieldCodeEditor'] cannot parse json" c
353
  --   Right j' -> case decodeJson j' of
354
  --     Left err -> here.log2 "[fieldCodeEditor'] cannot decode json" j'
355 356
  --     Right j'' -> onc $ JSON j''
changeCode onc (JSON j) CE.Markdown _ = onc $ Markdown $ defaultMarkdown' { text = text }
357
  where
358
    text = R2.stringify (JSON.writeImpl j) 2
359 360


361 362
type LoadProps =
  ( nodeId  :: Int
363 364
  , session :: Session
  )
365

366
loadCorpus' :: Record LoadProps -> AffRESTError (NodePoly Hyperdata)
367
loadCorpus' {nodeId, session} = get session $ NodeAPI Corpus (Just nodeId) ""
368

369
-- Just to make reloading effective
370
loadCorpusWithReload :: { reload :: T2.Reload  | LoadProps } -> AffRESTError (NodePoly Hyperdata)
371
loadCorpusWithReload {nodeId, session} = loadCorpus' {nodeId, session}
372

373 374 375 376 377
type SaveProps = (
  hyperdata :: Hyperdata
  | LoadProps
  )

378
saveCorpus :: Record SaveProps -> AffRESTError Int
379
saveCorpus {hyperdata, nodeId, session} = do
380
  put session (NodeAPI Corpus (Just nodeId) "") hyperdata
381

382
loadCorpus :: Record LoadProps -> AffRESTError CorpusData
383
loadCorpus {nodeId, session} = do
384
  -- fetch corpus via lists parentId
385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401
  res <- get session nodePolyRoute
  case res of
    Left err -> pure $ Left err
    Right (NodePoly {parentId: corpusId} :: NodePoly {}) -> do
      eCorpusNode     <-  get session $ corpusNodeRoute     corpusId ""
      eDefaultListIds <- (get session $ defaultListIdsRoute corpusId)
                      :: forall a. JSON.ReadForeign a => AffETableResult (NodePoly a)
      case eCorpusNode of
        Left err -> pure $ Left err
        Right corpusNode -> do
          case eDefaultListIds of
            Left err -> pure $ Left err
            Right defaultListIds -> do
              case (A.head defaultListIds.docs :: Maybe (NodePoly HyperdataList)) of
                Just (NodePoly { id: defaultListId }) ->
                  pure $ Right { corpusId, corpusNode, defaultListId }
                Nothing ->
402
                  pure $ Left $ CustomError "Missing default list"
403 404 405 406 407 408 409 410 411 412

--  (NodePoly {parentId: corpusId} :: NodePoly {}) <- get session nodePolyRoute
--  corpusNode     <-  get session $ corpusNodeRoute     corpusId ""
--  defaultListIds <- (get session $ defaultListIdsRoute corpusId)
--                    :: forall a. JSON.ReadForeign 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"
413
  where
414
    nodePolyRoute       = NodeAPI Corpus (Just nodeId) ""
415 416
    corpusNodeRoute     = NodeAPI Corpus <<< Just
    defaultListIdsRoute = Children NodeList 0 1 Nothing <<< Just
417 418


419
loadCorpusWithChild :: Record LoadProps -> AffRESTError CorpusData
420
loadCorpusWithChild { nodeId: childId, session } = do
421
  -- fetch corpus via lists parentId
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440
  eListNode <- get session $ listNodeRoute childId ""
  case eListNode of
    Left err -> pure $ Left err
    Right listNode -> do
      let (NodePoly {parentId: corpusId} :: NodePoly {}) = listNode
      eCorpusNode     <-  get session $ corpusNodeRoute     corpusId ""
      case eCorpusNode of
        Left err -> pure $ Left err
        Right corpusNode -> do
          eDefaultListIds <- (get session $ defaultListIdsRoute corpusId)
                             :: forall a. JSON.ReadForeign a => AffETableResult (NodePoly a)
          case eDefaultListIds of
            Left err -> pure $ Left err
            Right defaultListIds -> do
              case (A.head defaultListIds.docs :: Maybe (NodePoly HyperdataList)) of
                Just (NodePoly { id: defaultListId }) ->
                  pure $ Right { corpusId, corpusNode, defaultListId }
                Nothing ->
                  throwError $ error "Missing default list"
441 442 443 444 445
  where
    corpusNodeRoute     = NodeAPI Corpus <<< Just
    listNodeRoute       = NodeAPI Node <<< Just
    defaultListIdsRoute = Children NodeList 0 1 Nothing <<< Just

446 447 448

type LoadWithReloadProps =
  (
449
    reload :: T2.Reload
450 451 452 453 454
  | LoadProps
  )


-- Just to make reloading effective
455
loadCorpusWithChildAndReload :: Record LoadWithReloadProps -> AffRESTError CorpusData
456
loadCorpusWithChildAndReload {nodeId, session} = loadCorpusWithChild {nodeId, session}
Karen Konou's avatar
Karen Konou committed
457 458

data ViewType = Code | Folders
459 460
derive instance Generic ViewType _
instance Eq ViewType where
Karen Konou's avatar
Karen Konou committed
461
  eq = genericEq
462
instance Show ViewType where
Karen Konou's avatar
Karen Konou committed
463 464 465 466
  show = genericShow

type ViewTypeSelectorProps =
  (
Karen Konou's avatar
Karen Konou committed
467
    state :: T.Box ViewType
Karen Konou's avatar
Karen Konou committed
468 469 470 471 472
  )

viewTypeSelector :: Record ViewTypeSelectorProps -> R.Element
viewTypeSelector p = R.createElement viewTypeSelectorCpt p []
viewTypeSelectorCpt :: R.Component ViewTypeSelectorProps
Karen Konou's avatar
Karen Konou committed
473
viewTypeSelectorCpt = here.component "viewTypeSelector" cpt
Karen Konou's avatar
Karen Konou committed
474
  where
Karen Konou's avatar
Karen Konou committed
475 476 477
    cpt {state} _ = do
      state' <- T.useLive T.unequal state

Karen Konou's avatar
Karen Konou committed
478 479
      pure $ H.div { className: "btn-group"
                   , role: "group" } [
Karen Konou's avatar
Karen Konou committed
480 481
          viewTypeButton Folders state' state
        , viewTypeButton Code state' state
Karen Konou's avatar
Karen Konou committed
482 483
        ]

Karen Konou's avatar
Karen Konou committed
484
    viewTypeButton viewType state' state =
Karen Konou's avatar
Karen Konou committed
485
      H.button { className: "btn btn-primary" <> active
Karen Konou's avatar
Karen Konou committed
486
               , on: { click: \_ -> T.write viewType state }
Karen Konou's avatar
Karen Konou committed
487 488 489 490 491
               , type: "button"
               } [
        H.i { className: "fa " <> (icon viewType) } []
      ]
      where
Karen Konou's avatar
Karen Konou committed
492
        active = if viewType == state' then " active" else ""
Karen Konou's avatar
Karen Konou committed
493 494 495

    icon Folders = "fa-folder"
    icon Code = "fa-code"