[CodeEditor] add Haskell

dist/styles/CodeEditor.css

@@ -90,15 +90,19 @@
   margin-left: 25px;
   padding-left: 25px;
 }
+.code-editor .editor .html.language-haskell {
+  font-family: Fira code, Fira Mono, Consolas, Menlo, Courier, monospace;
+  white-space: pre;
+}
+.code-editor .editor .html.language-json {
+  font-family: Fira code, Fira Mono, Consolas, Menlo, Courier, monospace;
+  white-space: pre;
+}
 .code-editor .editor .html.language-md ul li {
   list-style: disc !important;
 }
 .code-editor .editor .html.language-md ol li {
   list-style: decimal !important;
 }
-.code-editor .editor .html.language-json {
-  font-family: Fira code, Fira Mono, Consolas, Menlo, Courier, monospace;
-  white-space: pre;
-}
 
 /*# sourceMappingURL=CodeEditor.css.map */

dist/styles/CodeEditor.sass

@@ -74,6 +74,12 @@
       flex-grow: 2
       margin-left: 25px
       padding-left: 25px
+      &.language-haskell
+        font-family: Fira code,Fira Mono,Consolas,Menlo,Courier,monospace
+        white-space: pre
+      &.language-json
+        font-family: Fira code,Fira Mono,Consolas,Menlo,Courier,monospace
+        white-space: pre
       &.language-md
         ul
           li
@@ -81,6 +87,3 @@
         ol
           li
             list-style: decimal !important
-      &.language-json
-        font-family: Fira code,Fira Mono,Consolas,Menlo,Courier,monospace
-        white-space: pre

src/Gargantext/Components/CodeEditor.purs

@@ -18,7 +18,7 @@ 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 (render)
+import Text.Smolder.Renderer.String as Smolder
 
 import Gargantext.Prelude
 import Gargantext.Utils.HighlightJS as HLJS
@@ -28,7 +28,7 @@ type Code = String
 type Html = String
 type Error = String
 
-data CodeType = JSON | Markdown
+data CodeType = Haskell | JSON | Markdown
 derive instance genericCodeType :: Generic CodeType _
 instance eqCodeType :: Eq CodeType where
   eq = genericEq
@@ -54,29 +54,35 @@ codeNlFix :: CodeType -> Code -> Code
 codeNlFix _ "" = " "
 codeNlFix _ c = if endsWith "\n" c then (c <> " ") else c
 
-compile :: CodeType -> Code -> Either Error Html
-compile JSON code = result
+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
-compile Markdown code = Right $ compileMd $ codeNlFix Markdown code
+render Markdown code = Right $ renderMd $ codeNlFix Markdown code
 
 previewPostProcess :: CodeType -> Element -> Effect Unit
-previewPostProcess Markdown _ = pure 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
-compileMd' :: forall e. MD.ToMarkupOptions e -> String -> String
-compileMd' options input =
-  either identity (MD.toMarkup' options >>> render)
+renderMd' :: forall e. MD.ToMarkupOptions e -> String -> String
+renderMd' options input =
+  either identity (MD.toMarkup' options >>> Smolder.render)
   (parseMd input :: Either String (SlamDownP String))
 
-compileMd :: String -> String
-compileMd = compileMd' MD.defaultToMarkupOptions
+renderMd :: String -> String
+renderMd = renderMd' MD.defaultToMarkupOptions
+
+renderHaskell :: String -> String
+renderHaskell s = s
 
 codeEditor :: Record Props -> R.Element
 codeEditor p = R.createElement codeEditorCpt p []
@@ -142,6 +148,7 @@ codeEditorCpt = R.hooksComponent "G.C.CE.CodeEditor" cpt
     dividerHidden _ = " hidden"
 
     langClass :: CodeType -> String
+    langClass Haskell = " language-haskell"
     langClass JSON = " language-json"
     langClass Markdown = " language-md"
 
@@ -174,12 +181,12 @@ renderHtml code {codeType: (codeType /\ _), htmlElRef, error: (_ /\ setError)} =
   case (toMaybe $ R.readRef htmlElRef) of
     Nothing -> pure unit
     Just htmlEl -> do
-      case compile codeType code of
+      case render codeType code of
         Left err -> do
           setError $ const $ Just err
-        Right compiled -> do
+        Right rendered -> do
           setError $ const Nothing
-          _ <- pure $ (htmlEl .= "innerHTML") compiled
+          _ <- pure $ (htmlEl .= "innerHTML") rendered
           previewPostProcess codeType htmlEl
           pure unit
 
@@ -239,7 +246,7 @@ codeTypeSelectorCpt = R.hooksComponent "G.C.CE.CodeTypeSelector" cpt
                 , on: { change: onSelectChange codeType onChange }
                 , style: { width: "150px" }
                 , value: show $ fst codeType }
-        (option <$> [JSON, Markdown])
+        (option <$> [Haskell, JSON, Markdown])
 
     option :: CodeType -> R.Element
     option value = H.option { value: show value } [ H.text $ show value ]
@@ -247,6 +254,7 @@ codeTypeSelectorCpt = R.hooksComponent "G.C.CE.CodeTypeSelector" cpt
     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

src/Gargantext/Components/Nodes/Corpus.purs

@@ -64,9 +64,6 @@ corpusLayoutViewCpt = R.hooksComponent "G.C.N.C.corpusLayoutView" cpt
       let fieldsWithIndex = A.mapWithIndex (\idx -> \t -> Tuple idx t) fields
       fieldsS <- R.useState' fieldsWithIndex
 
-      R.useEffect' $ do
-        log2 "[corpusLayoutViewCpt] reload" $ fst reload
-
       pure $ H.div {} [
           H.div { className: "row" } [
             H.div { className: "btn btn-default " <> (saveEnabled fieldsWithIndex fieldsS)
@@ -125,7 +122,6 @@ fieldsCodeEditorCpt = R.hooksComponent "G.C.N.C.fieldsCodeEditorCpt" cpt
 
     onChange :: R.State (Array FTFieldWithIndex) -> Index -> FieldType -> Effect Unit
     onChange (_ /\ setFields) idx typ = do
-      log2 "[fieldsCodeEditorCpt] onChange" typ
       setFields $ \fields ->
         case A.modifyAt idx (\(Tuple _ (Field f)) -> Tuple idx (Field $ f { typ = typ })) fields of
           Nothing -> fields
@@ -157,13 +153,12 @@ fieldCodeEditor props = R.createElement fieldCodeEditorCpt props []
 fieldCodeEditorCpt :: R.Component FieldCodeEditorProps
 fieldCodeEditorCpt = R.hooksComponent "G.C.N.C.fieldCodeEditorCpt" cpt
   where
-    cpt {field: Field {typ: Markdown md@{text}}, onChange} _ = do
-      pure $ CE.codeEditor {code: text, defaultCodeType: CE.Markdown, onChange: onChange'}
+    cpt {field: Field {typ: Haskell hs@{code}}, onChange} _ = do
+      pure $ CE.codeEditor {code, defaultCodeType: CE.Haskell, onChange: onChange'}
       where
         onChange' :: CE.Code -> Effect Unit
         onChange' c = do
-          log2 "[fieldCodeEditor'] Markdown c" c
-          onChange $ Markdown $ md { text = c }
+          onChange $ Haskell $ hs { code = c }
     cpt {field: Field {typ: JSON j}, onChange} _ = do
       pure $ CE.codeEditor {code, defaultCodeType: CE.JSON, onChange: onChange'}
       where
@@ -171,12 +166,17 @@ fieldCodeEditorCpt = R.hooksComponent "G.C.N.C.fieldCodeEditorCpt" cpt
 
         onChange' :: CE.Code -> Effect Unit
         onChange' c = do
-          log2 "[fieldCodeEditor'] JSON c" c
           case jsonParser c of
             Left err -> log2 "[fieldCodeEditor'] cannot parse json" c
             Right j' -> case decodeJson j' of
               Left err -> log2 "[fieldCodeEditor'] cannot decode json" j'
               Right j'' -> onChange $ JSON j''
+    cpt {field: Field {typ: Markdown md@{text}}, onChange} _ = do
+      pure $ CE.codeEditor {code: text, defaultCodeType: CE.Markdown, onChange: onChange'}
+      where
+        onChange' :: CE.Code -> Effect Unit
+        onChange' c = do
+          onChange $ Markdown $ md { text = c }
 
 type LoadProps = (
     nodeId  :: Int

src/Gargantext/Components/Nodes/Corpus/Types.purs

@@ -15,6 +15,7 @@ type Description = String
 type Query = String
 type Tag = String
 type Title = String
+type HaskellCode = String
 type MarkdownText = String
 
 newtype Hyperdata =
@@ -41,7 +42,12 @@ derive instance genericFTField :: Generic (Field FieldType) _
 instance eqFTField :: Eq (Field FieldType) where
   eq = genericEq
 
-data FieldType = JSON {
+data FieldType =
+    Haskell {
+    code             :: HaskellCode
+  , tag              :: Tag
+  }
+  | JSON {
     authors        :: Author
   , desc           :: Description
   , query          :: Query
@@ -62,6 +68,10 @@ instance decodeFTField :: DecodeJson (Field FieldType) where
     type_ <- obj .: "type"
     data_ <- obj .: "data"
     typ <- case type_ of
+      "Haskell" -> do
+        code <- data_ .: "code"
+        tag <- data_ .: "tag"
+        pure $ Haskell {code, tag}
       "JSON" -> do
         authors <- data_ .: "authors"
         desc <- data_ .: "desc"
@@ -82,9 +92,14 @@ instance encodeFTField :: EncodeJson (Field FieldType) where
     ~> "type"   := typ' typ
     ~> jsonEmptyObject
     where
+      typ' (Haskell _) = "Haskell"
       typ' (JSON _) = "JSON"
       typ' (Markdown _) = "Markdown"
 instance encodeFieldType :: EncodeJson FieldType where
+  encodeJson (Haskell {code}) =
+       "code" := code
+    ~> "tag"  := "HaskellField"
+    ~> jsonEmptyObject
   encodeJson (JSON {authors, desc, query, tag, title}) =
        "authors" := authors
     ~> "desc"    := desc