{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Text.MMark.Extension.GhcSyntaxHighlighter
-- Copyright   :  © 2018–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Use the @ghc-syntax-highlighter@ package to highlight Haskell code.
--
-- @since 0.2.1.0
module Text.MMark.Extension.GhcSyntaxHighlighter
  ( ghcSyntaxHighlighter,
  )
where

import Data.Text (Text)
import qualified Data.Text as T
import GHC.SyntaxHighlighter
import Lucid
import Text.MMark.Extension (Block (..), Extension)
import qualified Text.MMark.Extension as Ext

-- | Use the @ghc-syntax-highlighter@ package to highlight Haskell code. The
-- extension is applied only to code blocks with the info string
-- @\"haskell\"@.
--
-- The resulting code block will be wrapped in a @div@ with class
-- @\"source-code\"@. The following @span@ classes can be used for styling:
--
--     * 'KeywordTok'     = @\"kw\"@
--     * 'PragmaTok'      = @\"pr\"@
--     * 'SymbolTok'      = @\"sy\"@
--     * 'VariableTok'    = @\"va\"@
--     * 'ConstructorTok' = @\"cr\"@
--     * 'OperatorTok'    = @\"op\"@
--     * 'CharTok'        = @\"ch\"@
--     * 'StringTok'      = @\"st\"@
--     * 'IntegerTok'     = @\"it\"@
--     * 'RationalTok'    = @\"ra\"@
--     * 'CommentTok'     = @\"co\"@
--     * 'SpaceTok'       = no
--     * 'OtherTok'       = @\"ot\"@
--
-- To use with 'Text.MMark.Extension.Skylighting.skylighting' the extension
-- should be applied /after/ the
-- 'Text.MMark.Extension.Skylighting.skylighting' extension so it can
-- overwrite its logic for code block with @\"haskell\"@ info string. So
-- place it on the left hand side of @('<>')@ or above
-- 'Text.MMark.Extension.Skylighting.skylighting' in the list passed to
-- 'Text.MMark.useExtensions'.
ghcSyntaxHighlighter :: Extension
ghcSyntaxHighlighter :: Extension
ghcSyntaxHighlighter = ((Block (Ois, Html ()) -> Html ())
 -> Block (Ois, Html ()) -> Html ())
-> Extension
Ext.blockRender (((Block (Ois, Html ()) -> Html ())
  -> Block (Ois, Html ()) -> Html ())
 -> Extension)
-> ((Block (Ois, Html ()) -> Html ())
    -> Block (Ois, Html ()) -> Html ())
-> Extension
forall a b. (a -> b) -> a -> b
$ \Block (Ois, Html ()) -> Html ()
old Block (Ois, Html ())
block ->
  case Block (Ois, Html ())
block of
    cb :: Block (Ois, Html ())
cb@(CodeBlock (Just Text
"haskell") Text
txt) ->
      case Text -> Maybe [(Token, Text)]
tokenizeHaskell Text
txt of
        Maybe [(Token, Text)]
Nothing -> Block (Ois, Html ()) -> Html ()
old Block (Ois, Html ())
cb
        Just [(Token, Text)]
toks -> do
          [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"source-code"]
            (Html () -> Html ()) -> (Html () -> Html ()) -> Html () -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html () -> Html ()
forall arg result. Term arg result => arg -> result
pre_
            (Html () -> Html ()) -> (Html () -> Html ()) -> Html () -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
code_ [Text -> Attribute
class_ Text
"language-haskell"]
            (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ ((Token, Text) -> Html ()) -> [(Token, Text)] -> Html ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Token, Text) -> Html ()
tokenToHtml [(Token, Text)]
toks
          Html ()
newline
    Block (Ois, Html ())
other -> Block (Ois, Html ()) -> Html ()
old Block (Ois, Html ())
other
  where
    newline :: Html ()
    newline :: Html ()
newline = Html ()
"\n"

-- | Render a single 'Token'.
tokenToHtml :: (Token, Text) -> Html ()
tokenToHtml :: (Token, Text) -> Html ()
tokenToHtml (Token
tokenType, Text
txt) =
  [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
rawClass | Bool -> Bool
not (Text -> Bool
T.null Text
rawClass)] (Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
txt)
  where
    rawClass :: Text
rawClass = Token -> Text
tokenClass Token
tokenType

-- | Return class corresponding to given 'TokenType'.
tokenClass :: Token -> Text
tokenClass :: Token -> Text
tokenClass = \case
  Token
KeywordTok -> Text
"kw"
  Token
PragmaTok -> Text
"pr"
  Token
SymbolTok -> Text
"sy"
  Token
VariableTok -> Text
"va"
  Token
ConstructorTok -> Text
"cr"
  Token
OperatorTok -> Text
"op"
  Token
CharTok -> Text
"ch"
  Token
StringTok -> Text
"st"
  Token
IntegerTok -> Text
"it"
  Token
RationalTok -> Text
"ra"
  Token
CommentTok -> Text
"co"
  Token
SpaceTok -> Text
""
  Token
OtherTok -> Text
"ot"