module Gargantext.Components.CodeEditor where import Gargantext.Prelude import DOM.Simple.Types (Element) import Data.Argonaut.Parser (jsonParser) import Data.Either (Either(..)) import Data.Eq.Generic (genericEq) import Data.Foldable (intercalate) import Data.Generic.Rep (class Generic) import Data.Maybe (Maybe(..)) import Data.Nullable (Nullable, null, toMaybe) import Data.Show.Generic (genericShow) import Data.String.Utils (endsWith) import Effect (Effect) import FFI.Simple ((.=)) import Gargantext.Components.Bootstrap as B import Gargantext.Utils.HighlightJS as HLJS import Gargantext.Utils.Reactix as R2 import MarkdownIt (renderString) import Reactix as R import Reactix.DOM.HTML as H import Toestand as T 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 -> Effect (Either Error Html) render Haskell code = pure $ Right $ renderHaskell $ codeNlFix Haskell code render Python code = pure $ Right $ renderPython $ codeNlFix Python code render JSON code = pure result where parsedE = jsonParser code result = case parsedE of Left err -> Left err Right parsed -> Right $ R2.stringify parsed 2 render Markdown code = do r <- renderMd $ codeNlFix Markdown code pure $ Right r 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 -> Effect String renderMd = renderString --renderMd = renderMd' MD.defaultToMarkupOptions renderHaskell :: String -> String renderHaskell s = s renderPython :: String -> String renderPython s = s -- | 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 codeEditor :: R2.Leaf Props codeEditor = R2.leaf codeEditorCpt codeEditorCpt :: R.Component Props codeEditorCpt = here.component "codeEditor" cpt where cpt {code, defaultCodeType, onChange} _ = do -- | States -- | 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 -- | Effects -- | R.useEffect2' codeS' codeType' $ do setCodeOverlay controls.codeOverlayElRef codeType' codeS' renderHtml codeS' codeType' controls.htmlElRef controls.error -- | Render -- | 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 } [] ] ] -- | Helpers -- | 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 r <- render codeType code case r 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 :: R2.Leaf ToolbarProps toolbar = R2.leaf toolbarCpt toolbarCpt :: R.Component ToolbarProps toolbarCpt = here.component "toolbar" cpt where cpt { controls: { codeS, codeType, viewType } , onChange } _ = do -- | States -- | codeS' <- T.useLive T.unequal codeS -- codeType' <- T.useLive T.unequal codeType -- | Render -- | pure $ H.div { className: intercalate " " [ "code-editor__toolbar" , "row no-gutters align-items-center mb-3" ] } [ 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 :: R2.Leaf CodeTypeSelectorProps codeTypeSelector = R2.leaf codeTypeSelectorCpt codeTypeSelectorCpt :: R.Component CodeTypeSelectorProps codeTypeSelectorCpt = here.component "codeTypeSelector" cpt where cpt { codeType, onChange } _ = do -- | States -- | codeType' <- T.useLive T.unequal codeType -- | Render -- | pure $ H.div { className: "input-group input-group-sm" } [ H.div { className: "input-group-prepend" } [ B.icon { name: "code" , className: "input-group-text" } ] , R2.select { className: "form-control" , defaultValue: show codeType' , on: { change: onSelectChange codeType onChange } , style: { width: "150px" } } (option <$> [JSON, Markdown, Haskell, Python]) ] -- | Helpers -- | 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.Leaf ViewTypeSelectorProps viewTypeSelector = R2.leaf viewTypeSelectorCpt viewTypeSelectorCpt :: R.Component ViewTypeSelectorProps viewTypeSelectorCpt = here.component "viewTypeSelector" cpt where cpt { state } _ = do -- | States -- | state' <- T.useLive T.unequal state -- | Render -- | pure $ H.div { className: "btn-group btn-group-sm" , role: "group" } [ viewTypeButton Code state' state , viewTypeButton Both state' state , viewTypeButton Preview state' state ] -- | Helpers -- | viewTypeButton viewType state' state = H.button { className: "btn btn-light" <> 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