module Gargantext.Components.CodeEditor where import Data.Argonaut.Parser (jsonParser) import Data.Either (either, Either(..)) import Data.Generic.Rep (class Generic) import Data.Generic.Rep.Eq (genericEq) import Data.Generic.Rep.Show (genericShow) import Data.Maybe (Maybe(..)) import Data.Nullable (Nullable, null, toMaybe) import Data.String.Utils (endsWith) import Data.Tuple (fst) import Data.Tuple.Nested ((/\)) import DOM.Simple.Types (Element) import Effect (Effect) import FFI.Simple ((.=), delay) 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 Gargantext.Prelude import Gargantext.Utils.HighlightJS as HLJS import Gargantext.Utils.Reactix as R2 type Code = String type Html = String type Error = String data CodeType = Haskell | JSON | Markdown 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 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 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 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 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 = R.hooksComponent "G.C.CE.CodeEditor" cpt where cpt {code, defaultCodeType, onChange} _ = do controls <- initControls code defaultCodeType -- Initial rendering of elements with given data -- Note: delay is necessary here, otherwise initially the HTML won't get -- rendered (DOM Element refs are still null) R.useEffectOnce $ delay unit $ \_ -> do _ <- renderHtml code controls pure $ pure unit R.useEffectOnce $ delay unit $ \_ -> do _ <- setCodeOverlay controls code pure $ pure unit pure $ H.div { className: "code-editor" } [ toolbar {controls, onChange} , H.div { className: "row error" } [ errorComponent {error: controls.error} ] , H.div { className: "row editor" } [ H.div { className: "code-area " <> (codeHidden $ fst controls.viewType) } [ H.div { className: "code-container" } [ H.textarea { defaultValue: code , on: { change: onEditChange controls onChange } , placeholder: "Type some code..." , ref: controls.codeElRef } [ ] , H.pre { className: (langClass $ fst controls.codeType) -- , contentEditable: "true" , ref: controls.codeOverlayElRef , rows: 30 --, on: { input: onEditChange (fst codeType) codeElRef htmlRef editorCodeRef error } } [] ] ] , H.div { className: "v-divider " <> (dividerHidden $ fst controls.viewType) } [ H.text " " ] , H.div { className: "html " <> (langClass $ fst controls.codeType) <> (previewHidden $ fst controls.viewType) , ref: controls.htmlElRef } [] ] ] codeHidden :: ViewType -> String codeHidden Code = "" codeHidden Both = "" codeHidden _ = " hidden" dividerHidden :: ViewType -> String dividerHidden Both = "" dividerHidden _ = " hidden" langClass :: CodeType -> String langClass Haskell = " language-haskell" langClass JSON = " language-json" langClass Markdown = " language-md" previewHidden :: ViewType -> String previewHidden Preview = "" previewHidden Both = "" previewHidden _ = " hidden" onEditChange :: forall e. Record Controls -> (CodeType -> Code -> Effect Unit) -> e -> Effect Unit onEditChange controls@{codeElRef, codeOverlayElRef, codeType: (codeType /\ _), editorCodeRef} onChange e = do let code = R2.unsafeEventValue e R.setRef editorCodeRef code setCodeOverlay controls code renderHtml (R.readRef controls.editorCodeRef) controls onChange codeType code 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 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 case render codeType code of Left err -> do setError $ const $ Just err Right rendered -> do setError $ const Nothing _ <- pure $ (htmlEl .= "innerHTML") rendered previewPostProcess codeType htmlEl pure unit type ToolbarProps = ( controls :: Record Controls , onChange :: CodeType -> Code -> Effect Unit ) toolbar :: Record ToolbarProps -> R.Element toolbar p = R.createElement toolbarCpt p [] toolbarCpt :: R.Component ToolbarProps toolbarCpt = R.hooksComponent "G.C.CE.toolbar" cpt where cpt props@{controls: {codeType, error, viewType}} _ = do pure $ H.div { className: "row toolbar" } [ codeTypeSelector { codeType , onChange: onChangeCodeType props } , viewTypeSelector {state: viewType} ] -- Handle rerendering of preview when viewType changed onChangeCodeType :: forall e. Record ToolbarProps -> e -> Effect Unit onChangeCodeType {controls, onChange} _ = do setCodeOverlay controls code renderHtml code controls onChange (fst controls.codeType) code where code = R.readRef controls.editorCodeRef type ErrorComponentProps = ( error :: R.State (Maybe Error) ) errorComponent :: Record ErrorComponentProps -> R.Element errorComponent p = R.createElement errorComponentCpt p [] errorComponentCpt :: R.Component ErrorComponentProps errorComponentCpt = R.hooksComponent "G.C.CE.ErrorComponent" cpt where cpt {error: (Nothing /\ _)} _ = pure $ H.div {} [] cpt {error: ((Just error) /\ _)} _ = do pure $ H.div { className: "text-danger" } [ H.text error ] type CodeTypeSelectorProps = ( codeType :: R.State CodeType , onChange :: CodeType -> Effect Unit ) codeTypeSelector :: Record CodeTypeSelectorProps -> R.Element codeTypeSelector p = R.createElement codeTypeSelectorCpt p [] codeTypeSelectorCpt :: R.Component CodeTypeSelectorProps codeTypeSelectorCpt = R.hooksComponent "G.C.CE.CodeTypeSelector" cpt where cpt {codeType, onChange} _ = do pure $ R2.select { className: "form-control" , on: { change: onSelectChange codeType onChange } , style: { width: "150px" } , value: show $ fst codeType } (option <$> [Haskell, JSON, Markdown]) option :: CodeType -> R.Element option value = H.option { value: show value } [ H.text $ show value ] onSelectChange :: forall e. R.State CodeType -> (CodeType -> Effect Unit) -> e -> Effect Unit onSelectChange (_ /\ setCodeType) onChange e = do let codeType = case value of "Haskell" -> Haskell "JSON" -> JSON "Markdown" -> Markdown _ -> Markdown setCodeType $ const codeType onChange codeType where value = R2.unsafeEventValue e type ViewTypeSelectorProps = ( state :: R.State ViewType ) viewTypeSelector :: Record ViewTypeSelectorProps -> R.Element viewTypeSelector p = R.createElement viewTypeSelectorCpt p [] viewTypeSelectorCpt :: R.Component ViewTypeSelectorProps viewTypeSelectorCpt = R.hooksComponent "G.C.CE.ViewTypeSelector" cpt where cpt {state} _ = pure $ H.div { className: "btn-group" } [ viewTypeButton Code state , viewTypeButton Both state , viewTypeButton Preview state ] 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 icon Preview = "glyphicon-eye-open" icon Both = "glyphicon-transfer" icon Code = "glyphicon-pencil" type Controls = ( codeElRef :: R.Ref (Nullable Element) , codeType :: R.State CodeType , codeOverlayElRef :: R.Ref (Nullable Element) , editorCodeRef :: R.Ref Code , 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 codeElRef <- R.useRef null codeOverlayElRef <- R.useRef null codeType <- R.useState' defaultCodeType editorCodeRef <- R.useRef code error <- R.useState' Nothing viewType <- R.useState' Both pure $ { codeElRef , codeType , codeOverlayElRef , editorCodeRef , error , htmlElRef , viewType }