1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
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
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
module Gargantext.Components.CodeEditor where
import Data.Argonaut.Parser (jsonParser)
import Data.Either (either, Either(..))
import Data.Generic.Rep (class Generic)
import Data.Eq.Generic (genericEq)
import Data.Show.Generic (genericShow)
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable, null, toMaybe)
import Data.String.Utils (endsWith)
import DOM.Simple.Types (Element)
import Effect (Effect)
import FFI.Simple ((.=))
import Reactix as R
import Reactix.DOM.HTML as H
import Text.Markdown.SlamDown.Parser (parseMd)
import Text.Markdown.SlamDown.Smolder as MD
import Text.Markdown.SlamDown.Syntax (SlamDownP)
import Text.Smolder.Renderer.String as Smolder
import Toestand as T
import Gargantext.Prelude
import Gargantext.Utils.HighlightJS as HLJS
import Gargantext.Utils.Reactix as R2
here :: R2.Here
here = R2.here "Gargantext.Components.CodeEditor"
type Code = String
type Html = String
type Error = String
type ElRef = R.Ref (Nullable Element)
data CodeType = Haskell | JSON | Markdown | Python
derive instance Generic CodeType _
instance Eq CodeType where
eq = genericEq
instance Show CodeType where
show = genericShow
data ViewType = Code | Preview | Both
derive instance Generic ViewType _
instance Eq ViewType where
eq = genericEq
instance Show ViewType where
show = genericShow
type Props =
( code :: Code
, defaultCodeType :: CodeType
, onChange :: CodeType -> Code -> Effect Unit
)
-- Fixes newlines in code
-- This is useful eg for proper rendering of the textarea overlay
codeNlFix :: CodeType -> Code -> Code
codeNlFix _ "" = " "
codeNlFix _ c = if endsWith "\n" c then (c <> " ") else c
render :: CodeType -> Code -> Either Error Html
render Haskell code = Right $ renderHaskell $ codeNlFix Haskell code
render Python code = Right $ renderPython $ codeNlFix Python code
render JSON code = result
where
parsedE = jsonParser code
result = case parsedE of
Left err -> Left err
Right parsed -> Right $ R2.stringify parsed 2
render Markdown code = Right $ renderMd $ codeNlFix Markdown code
previewPostProcess :: CodeType -> Element -> Effect Unit
previewPostProcess Haskell htmlEl = do
HLJS.highlightBlock htmlEl
previewPostProcess Python htmlEl = do
HLJS.highlightBlock htmlEl
previewPostProcess JSON htmlEl = do
HLJS.highlightBlock htmlEl
previewPostProcess Markdown _ = pure unit
-- TODO Replace with markdown-it?
-- https://pursuit.purescript.org/packages/purescript-markdown-it
renderMd' :: forall e. MD.ToMarkupOptions e -> String -> String
renderMd' options input =
either identity (MD.toMarkup' options >>> Smolder.render)
(parseMd input :: Either String (SlamDownP String))
renderMd :: String -> String
renderMd = renderMd' MD.defaultToMarkupOptions
renderHaskell :: String -> String
renderHaskell s = s
renderPython :: String -> String
renderPython s = s
codeEditor :: Record Props -> R.Element
codeEditor p = R.createElement codeEditorCpt p []
-- 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
codeEditorCpt :: R.Component Props
codeEditorCpt = here.component "codeEditor" cpt
where
cpt {code, defaultCodeType, onChange} _ = do
controls <- initControls code defaultCodeType
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
pure $ H.div { className: "code-editor" }
[ toolbar { controls, onChange }
, H.div { className: "row no-gutters error" }
[ errorComponent {error: controls.error} ]
, H.div { className: "row no-gutters editor" }
[ H.div { className: "code-area " <> (codeHidden viewType') }
[ H.div { className: "code-container" }
[ H.textarea { defaultValue: codeS'
, on: { change: onEditChange controls.codeS codeType' onChange }
, placeholder: "Type some code..."
, ref: controls.codeElRef } [ ]
, H.pre { className: (langClass codeType')
-- , contentEditable: "true"
, ref: controls.codeOverlayElRef
, rows: 30
--, on: { input: onEditChange (fst codeType) codeElRef htmlRef codeRef error }
} []
]
]
, H.div { className: "v-divider " <> (dividerHidden viewType') } [ H.text " " ]
, H.div { className: "html " <> (langClass codeType') <> (previewHidden viewType')
, ref: controls.htmlElRef
} []
]
]
codeHidden :: ViewType -> String
codeHidden Code = ""
codeHidden Both = ""
codeHidden _ = " d-none"
dividerHidden :: ViewType -> String
dividerHidden Both = ""
dividerHidden _ = " d-none"
langClass :: CodeType -> String
langClass Haskell = " language-haskell"
langClass JSON = " language-json"
langClass Markdown = " language-md"
langClass Python = " language-python"
previewHidden :: ViewType -> String
previewHidden Preview = ""
previewHidden Both = ""
previewHidden _ = " d-none"
onEditChange :: forall e. T.Box Code -> CodeType -> OnChangeCodeType -> e -> Effect Unit
onEditChange codeS codeType onChange e = do
let code = R.unsafeEventValue e
T.write_ code codeS
onChange codeType code
setCodeOverlay :: ElRef -> CodeType -> Code -> Effect Unit
setCodeOverlay codeOverlayElRef 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
renderHtml :: Code -> CodeType -> ElRef -> T.Box (Maybe Error) -> Effect Unit
renderHtml code codeType htmlElRef error =
case (toMaybe $ R.readRef htmlElRef) of
Nothing -> pure unit
Just htmlEl -> do
case render codeType code of
Left err -> do
T.write_ (Just err) error
Right rendered -> do
T.write_ Nothing error
_ <- pure $ (htmlEl .= "innerHTML") rendered
previewPostProcess codeType htmlEl
pure unit
type OnChangeCodeType = CodeType -> Code -> Effect Unit
type ToolbarProps = (
controls :: Record Controls
, onChange :: OnChangeCodeType
)
toolbar :: Record ToolbarProps -> R.Element
toolbar p = R.createElement toolbarCpt p []
toolbarCpt :: R.Component ToolbarProps
toolbarCpt = here.component "toolbar" cpt
where
cpt { controls: { codeS, codeType, viewType }
, onChange } _ = do
codeS' <- T.useLive T.unequal codeS
codeType' <- T.useLive T.unequal codeType
pure $
H.div { className: "row no-gutters align-items-center mb-3 code-editor__toolbar" }
[ H.div { className: "code-editor__toolbar__type" }
[ codeTypeSelector {
codeType
-- Handle rerendering of preview when viewType changed
, onChange: \ct -> onChange ct codeS'
}
]
, H.div {}
[ viewTypeSelector {state: viewType} [] ]
]
type ErrorComponentProps =
(
error :: T.Box (Maybe Error)
)
errorComponent :: Record ErrorComponentProps -> R.Element
errorComponent p = R.createElement errorComponentCpt p []
errorComponentCpt :: R.Component ErrorComponentProps
errorComponentCpt = here.component "errorComponent" cpt
where
cpt { error } _ = do
error' <- T.useLive T.unequal error
pure $ case error' of
Nothing -> H.div {} []
Just err -> H.div { className: "text-danger mb-3" } [ H.text err ]
type CodeTypeSelectorProps =
(
codeType :: T.Box CodeType
, onChange :: CodeType -> Effect Unit
)
codeTypeSelector :: Record CodeTypeSelectorProps -> R.Element
codeTypeSelector p = R.createElement codeTypeSelectorCpt p []
codeTypeSelectorCpt :: R.Component CodeTypeSelectorProps
codeTypeSelectorCpt = here.component "codeTypeSelector" cpt
where
cpt { codeType, onChange } _ = do
codeType' <- T.useLive T.unequal codeType
pure $ R2.select { className: "form-control"
, defaultValue: show codeType'
, on: { change: onSelectChange codeType onChange }
, style: { width: "150px" }
}
(option <$> [JSON, Markdown, Haskell, Python])
option :: CodeType -> R.Element
option value = H.option { value: show value } [ H.text $ show value ]
onSelectChange :: forall e. T.Box CodeType -> (CodeType -> Effect Unit) -> e -> Effect Unit
onSelectChange codeType onChange e = do
let ct = case value of
"Haskell" -> Haskell
"JSON" -> JSON
"Markdown" -> Markdown
"Python" -> Python
_ -> Markdown
T.write_ ct codeType
onChange ct
where
value = R.unsafeEventValue e
type ViewTypeSelectorProps =
(
state :: T.Box ViewType
)
viewTypeSelector :: R2.Component ViewTypeSelectorProps
viewTypeSelector = R.createElement viewTypeSelectorCpt
viewTypeSelectorCpt :: R.Component ViewTypeSelectorProps
viewTypeSelectorCpt = here.component "viewTypeSelector" cpt
where
cpt { state } _ = do
state' <- T.useLive T.unequal state
pure $ H.div { className: "btn-group"
, role: "group" } [
viewTypeButton Code state' state
, viewTypeButton Both state' state
, viewTypeButton Preview state' state
]
viewTypeButton viewType state' state =
H.button { className: "btn btn-primary" <> active
, on: { click: \_ -> T.write viewType state }
, type: "button"
} [
H.i { className: "fa " <> (icon viewType) } []
]
where
active = if viewType == state' then " active" else ""
icon Preview = "fa-eye"
icon Both = "fa-columns"
icon Code = "fa-pencil"
type Controls =
(
codeElRef :: R.Ref (Nullable Element)
, codeS :: T.Box Code
, codeType :: T.Box CodeType
, codeOverlayElRef :: R.Ref (Nullable Element)
, error :: T.Box (Maybe Error)
, htmlElRef :: R.Ref (Nullable Element)
, viewType :: T.Box ViewType
)
initControls :: Code -> CodeType -> R.Hooks (Record Controls)
initControls code defaultCodeType = do
htmlElRef <- R.useRef null
codeS <- T.useBox code
codeElRef <- R.useRef null
codeOverlayElRef <- R.useRef null
codeType <- T.useBox defaultCodeType
error <- T.useBox Nothing
viewType <- T.useBox Preview
pure $ {
codeElRef
, codeS
, codeType
, codeOverlayElRef
, error
, htmlElRef
, viewType
}
reinitControls :: Record Controls -> Code -> CodeType -> Effect Unit
reinitControls { codeType, codeS, error } code defaultCodeType = do
T.write_ defaultCodeType codeType
T.write_ code codeS
T.write_ Nothing error