CodeEditor.purs 11.4 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 7 8
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Show (genericShow)
9 10
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable, null, toMaybe)
11
import Data.String.Utils (endsWith)
12
import Data.Tuple (fst, snd)
13 14
import Data.Tuple.Nested ((/\))
import Effect (Effect)
Alexandre Delanoë's avatar
Alexandre Delanoë committed
15
import FFI.Simple ((.=))
16 17 18 19
import Reactix as R
import Reactix.DOM.HTML as H
import Text.Markdown.SlamDown.Parser (parseMd)
import Text.Markdown.SlamDown.Smolder as MD
20
import Text.Markdown.SlamDown.Syntax (SlamDownP)
21
import Text.Smolder.Renderer.String as Smolder
22
import Toestand as T
23

24
import Gargantext.Prelude
25
import Gargantext.Utils.HighlightJS as HLJS
26
import Gargantext.Utils.Reactix as R2
27
import Gargantext.Utils.Toestand as T2
28

29 30
here :: R2.Here
here = R2.here "Gargantext.Components.CodeEditor"
31

32 33 34
type Code = String
type Html = String
type Error = String
35
type ElRef = R.Ref (Nullable Element)
36

37 38
data CodeType = Haskell | JSON | Markdown | Python

39 40 41 42 43 44 45 46 47 48 49 50
derive instance genericCodeType :: Generic CodeType _
instance eqCodeType :: Eq CodeType where
  eq = genericEq
instance showCodeType :: Show CodeType where
  show = genericShow

data ViewType = Code | Preview | Both
derive instance genericViewType :: Generic ViewType _
instance eqViewType :: Eq ViewType where
  eq = genericEq
instance showViewType :: Show ViewType where
  show = genericShow
51 52

type Props =
53
  ( code :: Code
54
  , defaultCodeType :: CodeType
55
  , onChange :: CodeType -> Code -> Effect Unit
56 57
  )

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

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

75
previewPostProcess :: CodeType -> Element -> Effect Unit
76 77
previewPostProcess Haskell htmlEl = do
  HLJS.highlightBlock htmlEl
78 79 80 81

previewPostProcess Python htmlEl = do
  HLJS.highlightBlock htmlEl

82 83
previewPostProcess JSON htmlEl = do
  HLJS.highlightBlock htmlEl
84

85
previewPostProcess Markdown _ = pure unit
86

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

94 95 96 97 98
renderMd :: String -> String
renderMd = renderMd' MD.defaultToMarkupOptions

renderHaskell :: String -> String
renderHaskell s = s
99

100 101 102 103
renderPython :: String -> String
renderPython s = s


104 105 106
codeEditor :: Record Props -> R.Element
codeEditor p = R.createElement codeEditorCpt p []

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

119 120 121 122 123 124 125
      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
126

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

153 154 155
    codeHidden :: ViewType -> String
    codeHidden Code = ""
    codeHidden Both = ""
156
    codeHidden _ = " d-none"
157

158 159
    dividerHidden :: ViewType -> String
    dividerHidden Both = ""
160
    dividerHidden _ = " d-none"
161

162
    langClass :: CodeType -> String
163 164
    langClass Haskell  = " language-haskell"
    langClass JSON     = " language-json"
165
    langClass Markdown = " language-md"
166
    langClass Python = " language-python"
167

168 169 170
    previewHidden :: ViewType -> String
    previewHidden Preview = ""
    previewHidden Both = ""
171
    previewHidden _ = " d-none"
172

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

179 180
setCodeOverlay :: ElRef -> CodeType -> Code -> Effect Unit
setCodeOverlay codeOverlayElRef codeType code = do
181 182 183 184 185 186 187 188 189
  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

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

204 205
type OnChangeCodeType = CodeType -> Code -> Effect Unit

206 207
type ToolbarProps = (
    controls :: Record Controls
208
  , onChange :: OnChangeCodeType
209 210 211
  )

toolbar :: Record ToolbarProps -> R.Element
212 213
toolbar p = R.createElement toolbarCpt p []

214
toolbarCpt :: R.Component ToolbarProps
215
toolbarCpt = here.component "toolbar" cpt
216
  where
217 218 219 220 221
    cpt props@{ controls: { codeS, codeType, error, viewType }
              , onChange } _ = do
      codeS' <- T.useLive T.unequal codeS
      codeType' <- T.useLive T.unequal codeType

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

235 236 237

type ErrorComponentProps =
  (
238
    error :: T.Box (Maybe Error)
239 240 241 242 243 244
  )

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

errorComponentCpt :: R.Component ErrorComponentProps
245
errorComponentCpt = here.component "errorComponent" cpt
246
  where
247 248 249 250 251 252
    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 ]
253 254 255 256


type CodeTypeSelectorProps =
  (
257
    codeType :: T.Box CodeType
258
  , onChange :: CodeType -> Effect Unit
259 260 261 262 263 264
  )

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

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

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

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

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


294
type ViewTypeSelectorProps =
295
  (
296
    state :: T.Box ViewType
297 298
  )

299 300
viewTypeSelector :: R2.Component ViewTypeSelectorProps
viewTypeSelector = R.createElement viewTypeSelectorCpt
301

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

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

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

325 326 327
    icon Preview = "fa-eye"
    icon Both = "fa-columns"
    icon Code = "fa-pencil"
328 329 330 331

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

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

  pure $ {
      codeElRef
352
    , codeS
353 354 355 356 357 358
    , codeType
    , codeOverlayElRef
    , error
    , htmlElRef
    , viewType
    }
359 360

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