CodeEditor.purs 10.8 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

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

27 28 29 30
type Code = String
type Html = String
type Error = String

31
data CodeType = Haskell | JSON | Markdown
32 33 34 35 36 37 38 39 40 41 42 43
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
44 45

type Props =
46
  ( code :: Code
47
  , defaultCodeType :: CodeType
48
  , onChange :: CodeType -> Code -> Effect Unit
49 50
  )

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

57 58 59
render :: CodeType -> Code -> Either Error Html
render Haskell code = Right $ renderHaskell $ codeNlFix Haskell code
render JSON code = result
60 61 62 63
  where
    parsedE = jsonParser code
    result = case parsedE of
      Left err -> Left err
64
      Right parsed -> Right $ R2.stringify parsed 2
65
render Markdown code = Right $ renderMd $ codeNlFix Markdown code
66

67
previewPostProcess :: CodeType -> Element -> Effect Unit
68 69
previewPostProcess Haskell htmlEl = do
  HLJS.highlightBlock htmlEl
70 71
previewPostProcess JSON htmlEl = do
  HLJS.highlightBlock htmlEl
72
previewPostProcess Markdown _ = pure unit
73

74 75
-- TODO Replace with markdown-it?
-- https://pursuit.purescript.org/packages/purescript-markdown-it
76 77 78
renderMd' :: forall e. MD.ToMarkupOptions e -> String -> String
renderMd' options input =
  either identity (MD.toMarkup' options >>> Smolder.render)
79 80
  (parseMd input :: Either String (SlamDownP String))

81 82 83 84 85
renderMd :: String -> String
renderMd = renderMd' MD.defaultToMarkupOptions

renderHaskell :: String -> String
renderHaskell s = s
86 87 88 89

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

90 91 92 93 94 95
-- 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
96
codeEditorCpt :: R.Component Props
97
codeEditorCpt = R.hooksComponent "G.C.CE.CodeEditor" cpt
98
  where
99
    cpt {code, defaultCodeType, onChange} _ = do
100
      controls <- initControls code defaultCodeType
101 102 103 104 105

      R.useEffect2' (fst controls.codeS) (fst controls.codeType) $ do
        let code' = fst controls.codeS
        setCodeOverlay controls code'
        renderHtml code' controls
106 107

      pure $ H.div { className: "code-editor" } [
108
          toolbar {controls, onChange}
109
        , H.div { className: "row error" } [
110
           errorComponent {error: controls.error}
111
        ]
112
        , H.div { className: "row editor" } [
113 114 115
           H.div { className: "code-area " <> (codeHidden $ fst controls.viewType) } [
             H.div { className: "code-container" } [
               H.textarea { defaultValue: code
116
                          , on: { change: onEditChange controls onChange }
117 118
                          , placeholder: "Type some code..."
                          , ref: controls.codeElRef } [ ]
119
               , H.pre  { className: (langClass $ fst controls.codeType)
120 121 122
                          -- , contentEditable: "true"
                        , ref: controls.codeOverlayElRef
                        , rows: 30
123
                          --, on: { input: onEditChange (fst codeType) codeElRef htmlRef codeRef error }
124 125 126
                        } []
               ]
             ]
127
           , H.div { className: "v-divider " <> (dividerHidden $ fst controls.viewType) } [ H.text " " ]
128
           , H.div { className: "html " <> (langClass $ fst controls.codeType) <> (previewHidden $ fst controls.viewType)
129 130
                   , ref: controls.htmlElRef
                   } []
131
           ]
132 133
        ]

134 135 136
    codeHidden :: ViewType -> String
    codeHidden Code = ""
    codeHidden Both = ""
137
    codeHidden _ = " hidden"
138

139 140
    dividerHidden :: ViewType -> String
    dividerHidden Both = ""
141
    dividerHidden _ = " hidden"
142

143
    langClass :: CodeType -> String
144 145
    langClass Haskell  = " language-haskell"
    langClass JSON     = " language-json"
146
    langClass Markdown = " language-md"
147

148 149 150
    previewHidden :: ViewType -> String
    previewHidden Preview = ""
    previewHidden Both = ""
151
    previewHidden _ = " hidden"
152

153
    onEditChange :: forall e. Record Controls -> (CodeType -> Code -> Effect Unit) -> e -> Effect Unit
154
    onEditChange controls@{codeElRef, codeOverlayElRef, codeType: (codeType /\ _), codeS} onChange e = do
155
      let code = R2.unsafeEventValue e
156
      snd codeS $ const code
157
      onChange codeType code
158

159 160 161 162 163 164 165 166 167 168 169
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
  pure unit

170 171 172 173 174
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
175
      case render codeType code of
176 177
        Left err -> do
          setError $ const $ Just err
178
        Right rendered -> do
179
          setError $ const Nothing
180
          _ <- pure $ (htmlEl .= "innerHTML") rendered
181
          previewPostProcess codeType htmlEl
182
          pure unit
183

184 185 186 187 188 189
type ToolbarProps = (
    controls :: Record Controls
  , onChange :: CodeType -> Code -> Effect Unit
  )

toolbar :: Record ToolbarProps -> R.Element
190 191
toolbar p = R.createElement toolbarCpt p []

192
toolbarCpt :: R.Component ToolbarProps
193 194
toolbarCpt = R.hooksComponent "G.C.CE.toolbar" cpt
  where
195
    cpt props@{controls: {codeType, error, viewType}} _ = do
196 197 198 199
      pure $
        H.div { className: "row toolbar" } [
             codeTypeSelector {
                  codeType
200
                , onChange: onChangeCodeType props
201 202 203 204 205
                }
           , viewTypeSelector {state: viewType}
           ]

    -- Handle rerendering of preview when viewType changed
206 207 208 209
    onChangeCodeType :: forall e. Record ToolbarProps -> e -> Effect Unit
    onChangeCodeType {controls, onChange} _ = do
      onChange (fst controls.codeType) code
      where
210
        code = fst controls.codeS
211

212 213 214 215 216 217 218 219 220 221

type ErrorComponentProps =
  (
    error :: R.State (Maybe Error)
  )

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

errorComponentCpt :: R.Component ErrorComponentProps
222
errorComponentCpt = R.hooksComponent "G.C.CE.ErrorComponent" cpt
223 224 225 226
  where
    cpt {error: (Nothing /\ _)} _ = pure $ H.div {} []
    cpt {error: ((Just error) /\ _)} _ = do
      pure $ H.div { className: "text-danger" } [ H.text error ]
227 228 229 230 231


type CodeTypeSelectorProps =
  (
    codeType :: R.State CodeType
232
  , onChange :: CodeType -> Effect Unit
233 234 235 236 237 238
  )

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

codeTypeSelectorCpt :: R.Component CodeTypeSelectorProps
239
codeTypeSelectorCpt = R.hooksComponent "G.C.CE.CodeTypeSelector" cpt
240
  where
241
    cpt {codeType, onChange} _ = do
242
      pure $ R2.select { className: "form-control"
243 244 245 246
                       , defaultValue: show $ fst codeType
                       , on: { change: onSelectChange codeType onChange }
                       , style: { width: "150px" }
                       }
247
        (option <$> [Haskell, JSON, Markdown])
248 249 250

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

    onSelectChange :: forall e. R.State CodeType -> (CodeType -> Effect Unit) -> e -> Effect Unit
    onSelectChange (_ /\ setCodeType) onChange e = do
254
      let codeType = case value of
255
            "Haskell"  -> Haskell
256 257 258 259
            "JSON"     -> JSON
            "Markdown" -> Markdown
            _          -> Markdown
      setCodeType $ const codeType
260
      onChange codeType
261 262 263 264
      where
        value = R2.unsafeEventValue e


265
type ViewTypeSelectorProps =
266
  (
267
    state :: R.State ViewType
268 269
  )

270 271
viewTypeSelector :: Record ViewTypeSelectorProps -> R.Element
viewTypeSelector p = R.createElement viewTypeSelectorCpt p []
272

273
viewTypeSelectorCpt :: R.Component ViewTypeSelectorProps
274
viewTypeSelectorCpt = R.hooksComponent "G.C.CE.ViewTypeSelector" cpt
275
  where
276 277 278 279 280 281
    cpt {state} _ =
      pure $ H.div { className: "btn-group" } [
          viewTypeButton Code state
        , viewTypeButton Both state
        , viewTypeButton Preview state
        ]
282

283 284 285 286 287 288 289 290 291 292 293 294
    viewTypeButton viewType (state /\ setState) =
      H.label {
        className: "btn btn-default" <> active
        , on: { click: onClick }
      } [
        H.i { className: "glyphicon " <> (icon viewType) } []
      ]
      where
        active = if viewType == state then " active" else ""

        onClick _ = do
          setState $ const viewType
295 296 297 298

    icon Preview = "glyphicon-eye-open"
    icon Both = "glyphicon-transfer"
    icon Code = "glyphicon-pencil"
299 300 301 302

type Controls =
  (
      codeElRef :: R.Ref (Nullable Element)
303
    , codeS :: R.State Code
304 305 306 307 308 309 310 311 312 313
    , codeType :: R.State CodeType
    , codeOverlayElRef :: R.Ref (Nullable Element)
    , 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
314
  codeS <- R.useState' code
315 316 317 318
  codeElRef <- R.useRef null
  codeOverlayElRef <- R.useRef null
  codeType <- R.useState' defaultCodeType
  error <- R.useState' Nothing
319
  viewType <- R.useState' Preview
320 321 322

  pure $ {
      codeElRef
323
    , codeS
324 325 326 327 328 329
    , codeType
    , codeOverlayElRef
    , error
    , htmlElRef
    , viewType
    }
330 331 332 333 334 335

reinitControls :: Record Controls -> Code -> CodeType -> Effect Unit
reinitControls c@{codeType, codeS, error} code defaultCodeType = do
  snd codeType $ const defaultCodeType
  snd codeS $ const code
  snd error $ const Nothing