Markdown syntax highlighting for rasa with rasa-ext-syntax

.gitignore

@@ -0,0 +1,21 @@
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+.HTF/
+*.log

README.md

@@ -0,0 +1,5 @@
+Rasa Markdown Syntax
+====================
+See the docs on [Hackage](https://hackage.haskell.org/package/rasa-ext-syntax-markdown)
+
+This package provides a markdown syntax highlighting extension for rasa.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

rasa-ext-syntax-markdown.cabal

@@ -0,0 +1,52 @@
+name:                rasa-ext-syntax-markdown
+version:             0.1.0
+synopsis:            Rasa Ext for Markdown syntax highlighting
+description:         Rasa Ext for Markdown syntax highlighting.
+homepage:            https://github.com/iilab/rasa-ext-syntax-markdown/
+license:             GPL-3
+license-file:        LICENSE
+author:              Jun Matsushita
+maintainer:          jun@iilab.org
+copyright:           2018 Jun Matsushita
+category:            Extension
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Rasa.Ext.Syntax.Markdown
+
+  build-depends:       base >= 4.8 && < 5
+                     , rasa
+                     , rasa-ext-syntax
+                     , text
+                     , yi-rope
+                     , text-lens
+                     , data-default
+                     , lens
+                     , mtl
+                     , cmark-gfm
+
+  default-language:    Haskell2010
+
+  default-extensions:
+
+  ghc-options:         -Wall
+
+test-suite rasa-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  build-depends:       base
+                     , rasa-ext-syntax
+                     , hspec
+  other-modules:
+                       Rasa.Ext.SyntaxSpec
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings
+
+source-repository head
+  type:     git
+  location: https://github.com/iilab/rasa-ext-syntax-markdown

src/Rasa/Ext/Syntax/Markdown.hs

@@ -0,0 +1,64 @@
+{-# language NamedFieldPuns #-}
+{-# language LambdaCase #-}
+module Rasa.Ext.Syntax.Markdown
+  ( lexer
+  , styler
+  , markdown
+  ) where
+
+import Rasa.Ext
+import Rasa.Ext.Syntax
+
+import qualified Yi.Rope as Y
+
+import CMarkGFM
+
+import Data.Default
+import Data.Typeable
+
+data MarkdownToken =
+  MdTitle | MdBold | MdEmph | MdQuote | MdList | MdOther
+  deriving (Typeable, Show)
+
+instance Default MarkdownToken where
+  def = MdOther
+
+lexer :: Lexer MarkdownToken
+lexer txt = lexNodes $ commonmarkToNode [] [] (Y.toText txt)
+
+lexNodes :: Node -> Tokens MarkdownToken
+lexNodes = \case
+  (Node (Nothing) _ _)                 -> Tokens []  -- Ignore nodes without positions
+  (Node (Just _) (TEXT _) _)           -> Tokens []  -- Ignore leaf nodes
+  (Node (Just _) DOCUMENT nodes)       ->     -- Skip the root node
+    Tokens $ concat $ ( (unToken . lexNodes) <$> nodes )
+  (Node (Just posinfo) nodeType nodes) ->
+    Tokens $ ( TokenRange (posToRange posinfo, nodeTypeToToken nodeType))
+           : ( concat $ ((unToken . lexNodes) <$> nodes ) )
+
+posToRange :: PosInfo -> CrdRange
+posToRange PosInfo{startLine,startColumn,endLine,endColumn} =
+  Range
+    (Coord (startLine - 1) (startColumn - 1))
+    (Coord (endLine - 1) endColumn)
+
+nodeTypeToToken :: NodeType -> MarkdownToken
+nodeTypeToToken = \case
+  (HEADING _)   -> MdTitle
+  (LIST _)      -> MdList
+  EMPH          -> MdEmph
+  STRONG        -> MdBold
+  BLOCK_QUOTE   -> MdQuote
+  _             -> MdOther
+
+styler :: Styler MarkdownToken
+styler = return . \case
+  (TokenRange (r, MdTitle)) -> Span r ((flair Bold) <> (flair Underline))
+  (TokenRange (r, MdList))  -> Span r (fg Blue)
+  (TokenRange (r, MdBold))  -> Span r (flair Bold)
+  (TokenRange (r, MdEmph))  -> Span r (flair Italic)
+  (TokenRange (r, MdQuote)) -> Span r (fg Green)
+  _                         -> Span (Range (Coord 0 0) (Coord 0 0)) mempty
+
+markdown :: Mapper -> Syntax MarkdownToken
+markdown mapper = Syntax "Markdown" mapper lexer styler

test/Rasa/Ext/SyntaxSpec.hs

@@ -0,0 +1,6 @@
+module Rasa.Ext.SyntaxSpec where
+
+import Test.Hspec
+
+spec :: Spec
+spec = return ()

test/Spec.hs

@@ -0,0 +1,2 @@
+-- file test/Spec.hs
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}