CodeEditor.purs 11.2 KB
Newer Older
1 2
module Gargantext.Components.CodeEditor where

Alexandre Delanoë's avatar
Alexandre Delanoë committed
3
import DOM.Simple.Types (Element)
4
import Data.Argonaut.Parser (jsonParser)
5
import Data.Either (either, Either(..))
6
import Data.Generic.Rep (class Generic)
7 8
import Data.Eq.Generic (genericEq)
import Data.Show.Generic (genericShow)
9 10
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable, null, toMaybe)
11
import Data.String.Utils (endsWith)
12
import Effect (Effect)
Alexandre Delanoë's avatar
Alexandre Delanoë committed
13
import FFI.Simple ((.=))
14 15 16 17
import Reactix as R
import Reactix.DOM.HTML as H
import Text.Markdown.SlamDown.Parser (parseMd)
import Text.Markdown.SlamDown.Smolder as MD
18
import Text.Markdown.SlamDown.Syntax (SlamDownP)
19
import Text.Smolder.Renderer.String as Smolder
20
import Toestand as T
21

22
import Gargantext.Prelude
23
import Gargantext.Utils.HighlightJS as HLJS
24 25
import Gargantext.Utils.Reactix as R2

26 27
here :: R2.Here
here = R2.here "Gargantext.Components.CodeEditor"
28

29 30 31
type Code = String
type Html = String
type Error = String
32
type ElRef = R.Ref (Nullable Element)
33

34 35
data CodeType = Haskell | JSON | Markdown | Python

36 37
derive instance Generic CodeType _
instance Eq CodeType where
38
  eq = genericEq
39
instance Show CodeType where
40 41 42
  show = genericShow

data ViewType = Code | Preview | Both
43 44
derive instance Generic ViewType _
instance Eq ViewType where
45
  eq = genericEq
46
instance Show ViewType where
47
  show = genericShow
48 49

type Props =
50
  ( code :: Code
51
  , defaultCodeType :: CodeType
52
  , onChange :: CodeType -> Code -> Effect Unit
53 54
  )

55 56 57
-- Fixes newlines in code
-- This is useful eg for proper rendering of the textarea overlay
codeNlFix :: CodeType -> Code -> Code
58 59
codeNlFix _ "" = " "
codeNlFix _ c = if endsWith "\n" c then (c <> " ") else c
60

61 62
render :: CodeType -> Code -> Either Error Html
render Haskell code = Right $ renderHaskell $ codeNlFix Haskell code
63
render Python  code = Right $ renderPython  $ codeNlFix Python code
64
render JSON code = result
65 66 67 68
  where
    parsedE = jsonParser code
    result = case parsedE of
      Left err -> Left err
69
      Right parsed -> Right $ R2.stringify parsed 2
70
render Markdown code = Right $ renderMd $ codeNlFix Markdown code
71

72
previewPostProcess :: CodeType -> Element -> Effect Unit
73 74
previewPostProcess Haskell htmlEl = do
  HLJS.highlightBlock htmlEl
75 76 77 78

previewPostProcess Python htmlEl = do
  HLJS.highlightBlock htmlEl

79 80
previewPostProcess JSON htmlEl = do
  HLJS.highlightBlock htmlEl
81

82
previewPostProcess Markdown _ = pure unit
83

84 85
-- TODO Replace with markdown-it?
-- https://pursuit.purescript.org/packages/purescript-markdown-it
86 87 88
renderMd' :: forall e. MD.ToMarkupOptions e -> String -> String
renderMd' options input =
  either identity (MD.toMarkup' options >>> Smolder.render)
89 90
  (parseMd input :: Either String (SlamDownP String))

91 92 93 94 95
renderMd :: String -> String
renderMd = renderMd' MD.defaultToMarkupOptions

renderHaskell :: String -> String
renderHaskell s = s
96

97 98 99 100
renderPython :: String -> String
renderPython s = s


101 102 103
codeEditor :: Record Props -> R.Element
codeEditor p = R.createElement codeEditorCpt p []

104 105 106 107 108 109
-- 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
110
codeEditorCpt :: R.Component Props
111
codeEditorCpt = here.component "codeEditor" cpt
112
  where
113
    cpt {code, defaultCodeType, onChange} _ = do
114
      controls <- initControls code defaultCodeType
115

116 117 118 119 120 121 122
      codeS' <- T.useLive T.unequal controls.codeS
      codeType' <- T.useLive T.unequal controls.codeType
      viewType' <- T.useLive T.unequal controls.viewType

      R.useEffect2' codeS' codeType' $ do
        setCodeOverlay controls.codeOverlayElRef codeType' codeS'
        renderHtml codeS' codeType' controls.htmlElRef controls.error
123

124
      pure $ H.div { className: "code-editor" }
125
        [ toolbar { controls, onChange }
126 127 128
        , H.div { className: "row error" }
          [ errorComponent {error: controls.error} ]
        , H.div { className: "row editor" }
129
          [ H.div { className: "code-area " <> (codeHidden viewType') }
130
            [ H.div { className: "code-container" }
131 132
              [ H.textarea { defaultValue: codeS'
                           , on: { change: onEditChange controls.codeS codeType' onChange }
133 134
                           , placeholder: "Type some code..."
                           , ref: controls.codeElRef } [ ]
135
              , H.pre  { className: (langClass codeType')
136 137 138 139 140 141
                         -- , contentEditable: "true"
                       , ref: controls.codeOverlayElRef
                       , rows: 30
                         --, on: { input: onEditChange (fst codeType) codeElRef htmlRef codeRef error }
                       } []
              ]
142
             ]
143 144
           , H.div { className: "v-divider " <> (dividerHidden viewType') } [ H.text " " ]
           , H.div { className: "html " <> (langClass codeType') <> (previewHidden viewType')
145 146
                   , ref: controls.htmlElRef
                   } []
147
           ]
148 149
        ]

150 151 152
    codeHidden :: ViewType -> String
    codeHidden Code = ""
    codeHidden Both = ""
153
    codeHidden _ = " d-none"
154

155 156
    dividerHidden :: ViewType -> String
    dividerHidden Both = ""
157
    dividerHidden _ = " d-none"
158

159
    langClass :: CodeType -> String
160 161
    langClass Haskell  = " language-haskell"
    langClass JSON     = " language-json"
162
    langClass Markdown = " language-md"
163
    langClass Python = " language-python"
164

165 166 167
    previewHidden :: ViewType -> String
    previewHidden Preview = ""
    previewHidden Both = ""
168
    previewHidden _ = " d-none"
169

170 171
    onEditChange :: forall e. T.Box Code -> CodeType -> OnChangeCodeType -> e -> Effect Unit
    onEditChange codeS codeType onChange e = do
172
      let code = R.unsafeEventValue e
173
      T.write_ code codeS
174
      onChange codeType code
175

176 177
setCodeOverlay :: ElRef -> CodeType -> Code -> Effect Unit
setCodeOverlay codeOverlayElRef codeType code = do
178 179 180 181 182 183 184 185 186
  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
  pure unit

187 188
renderHtml :: Code -> CodeType -> ElRef -> T.Box (Maybe Error) -> Effect Unit
renderHtml code codeType htmlElRef error =
189 190 191
  case (toMaybe $ R.readRef htmlElRef) of
    Nothing -> pure unit
    Just htmlEl -> do
192
      case render codeType code of
193
        Left err -> do
194
          T.write_ (Just err) error
195
        Right rendered -> do
196
          T.write_ Nothing error
197
          _ <- pure $ (htmlEl .= "innerHTML") rendered
198
          previewPostProcess codeType htmlEl
199
          pure unit
200

201 202
type OnChangeCodeType = CodeType -> Code -> Effect Unit

203 204
type ToolbarProps = (
    controls :: Record Controls
205
  , onChange :: OnChangeCodeType
206 207 208
  )

toolbar :: Record ToolbarProps -> R.Element
209 210
toolbar p = R.createElement toolbarCpt p []

211
toolbarCpt :: R.Component ToolbarProps
212
toolbarCpt = here.component "toolbar" cpt
213
  where
214 215
    cpt { controls: { codeS, codeType, viewType }
        , onChange } _ = do
216 217 218
      codeS' <- T.useLive T.unequal codeS
      codeType' <- T.useLive T.unequal codeType

219
      pure $
220 221 222 223
        H.div { className: "row toolbar" }
          [ H.div { className: "col-2" }
               [ codeTypeSelector {
                   codeType
224 225
                  -- Handle rerendering of preview when viewType changed
                 , onChange: \ct -> onChange ct codeS'
226 227 228
                 }
               ]
          , H.div { className: "col-1" }
229
             [ viewTypeSelector {state: viewType} [] ]
230
          ]
231

232 233 234

type ErrorComponentProps =
  (
235
    error :: T.Box (Maybe Error)
236 237 238 239 240 241
  )

errorComponent :: Record ErrorComponentProps -> R.Element
errorComponent p = R.createElement errorComponentCpt p []

errorComponentCpt :: R.Component ErrorComponentProps
242
errorComponentCpt = here.component "errorComponent" cpt
243
  where
244 245 246 247 248 249
    cpt { error } _ = do
      error' <- T.useLive T.unequal error

      pure $ case error' of
        Nothing -> H.div {} []
        Just err -> H.div { className: "text-danger" } [ H.text err ]
250 251 252 253


type CodeTypeSelectorProps =
  (
254
    codeType :: T.Box CodeType
255
  , onChange :: CodeType -> Effect Unit
256 257 258 259 260 261
  )

codeTypeSelector :: Record CodeTypeSelectorProps -> R.Element
codeTypeSelector p = R.createElement codeTypeSelectorCpt p []

codeTypeSelectorCpt :: R.Component CodeTypeSelectorProps
262
codeTypeSelectorCpt = here.component "codeTypeSelector" cpt
263
  where
264 265 266
    cpt { codeType, onChange } _ = do
      codeType' <- T.useLive T.unequal codeType

267
      pure $ R2.select { className: "form-control"
268
                       , defaultValue: show codeType'
269 270 271
                       , on: { change: onSelectChange codeType onChange }
                       , style: { width: "150px" }
                       }
272
        (option <$> [JSON, Markdown, Haskell, Python])
273 274 275

    option :: CodeType -> R.Element
    option value = H.option { value: show value } [ H.text $ show value ]
276

277 278 279
    onSelectChange :: forall e. T.Box CodeType -> (CodeType -> Effect Unit) -> e -> Effect Unit
    onSelectChange codeType onChange e = do
      let ct = case value of
280
            "Haskell"  -> Haskell
281 282
            "JSON"     -> JSON
            "Markdown" -> Markdown
283
            "Python"   -> Python
284
            _          -> Markdown
285 286
      T.write_ ct codeType
      onChange ct
287
      where
288
        value = R.unsafeEventValue e
289 290


291
type ViewTypeSelectorProps =
292
  (
293
    state :: T.Box ViewType
294 295
  )

296 297
viewTypeSelector :: R2.Component ViewTypeSelectorProps
viewTypeSelector = R.createElement viewTypeSelectorCpt
298

299
viewTypeSelectorCpt :: R.Component ViewTypeSelectorProps
300
viewTypeSelectorCpt = here.component "viewTypeSelector" cpt
301
  where
302 303 304
    cpt { state } _ = do
      state' <- T.useLive T.unequal state

305 306
      pure $ H.div { className: "btn-group"
                   , role: "group" } [
307 308 309
          viewTypeButton Code state' state
        , viewTypeButton Both state' state
        , viewTypeButton Preview state' state
310
        ]
311

312
    viewTypeButton viewType state' state =
313
      H.button { className: "btn btn-primary" <> active
314
               , on: { click: \_ -> T.write viewType state }
315 316 317
               , type: "button"
               } [
        H.i { className: "fa " <> (icon viewType) } []
318 319
      ]
      where
320
        active = if viewType == state' then " active" else ""
321

322 323 324
    icon Preview = "fa-eye"
    icon Both = "fa-columns"
    icon Code = "fa-pencil"
325 326 327 328

type Controls =
  (
      codeElRef :: R.Ref (Nullable Element)
329 330
    , codeS :: T.Box Code
    , codeType :: T.Box CodeType
331
    , codeOverlayElRef :: R.Ref (Nullable Element)
332
    , error :: T.Box (Maybe Error)
333
    , htmlElRef :: R.Ref (Nullable Element)
334
    , viewType :: T.Box ViewType
335 336 337 338 339
  )

initControls :: Code -> CodeType -> R.Hooks (Record Controls)
initControls code defaultCodeType = do
  htmlElRef <- R.useRef null
340
  codeS <- T.useBox code
341 342
  codeElRef <- R.useRef null
  codeOverlayElRef <- R.useRef null
343 344 345
  codeType <- T.useBox defaultCodeType
  error <- T.useBox Nothing
  viewType <- T.useBox Preview
346 347 348

  pure $ {
      codeElRef
349
    , codeS
350 351 352 353 354 355
    , codeType
    , codeOverlayElRef
    , error
    , htmlElRef
    , viewType
    }
356 357

reinitControls :: Record Controls -> Code -> CodeType -> Effect Unit
358 359 360 361
reinitControls c@{ codeType, codeS, error } code defaultCodeType = do
  T.write_ defaultCodeType codeType
  T.write_ code codeS
  T.write_ Nothing error