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

-- |
-- Module      :  Text.MMark.Extension.Skylighting
-- Copyright   :  © 2018–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Use the Skylighting library to highlight code snippets.
module Text.MMark.Extension.Skylighting
  ( skylighting,
  )
where

import Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
import Lucid
import Skylighting (Token, TokenType (..))
import qualified Skylighting as S
import Text.MMark.Extension (Block (..), Extension)
import qualified Text.MMark.Extension as Ext

-- | Use the @skylighting@ package to render code blocks with info strings
-- that result in a successful lookup from 'S.defaultSyntaxMap'.
--
-- The resulting code block will be wrapped in a @div@ with class
-- @\"source-code\"@. The following @span@ classes can be used for styling:
--
--     * 'AlertTok'          = @\"al\"@
--     * 'AnnotationTok'     = @\"an\"@
--     * 'AttributeTok'      = @\"at\"@
--     * 'BaseNTok'          = @\"bn\"@
--     * 'BuiltInTok'        = @\"bu\"@
--     * 'CharTok'           = @\"ch\"@
--     * 'CommentTok'        = @\"co\"@
--     * 'CommentVarTok'     = @\"cv\"@
--     * 'ConstantTok'       = @\"cn\"@
--     * 'ControlFlowTok'    = @\"cf\"@
--     * 'DataTypeTok'       = @\"dt\"@
--     * 'DecValTok'         = @\"dv\"@
--     * 'DocumentationTok'  = @\"do\"@
--     * 'ErrorTok'          = @\"er\"@
--     * 'ExtensionTok'      = @\"ex\"@
--     * 'FloatTok'          = @\"fl\"@
--     * 'FunctionTok'       = @\"fu\"@
--     * 'ImportTok'         = @\"im\"@
--     * 'InformationTok'    = @\"in\"@
--     * 'KeywordTok'        = @\"kw\"@
--     * 'OperatorTok'       = @\"op\"@
--     * 'OtherTok'          = @\"ot\"@
--     * 'PreprocessorTok'   = @\"pp\"@
--     * 'RegionMarkerTok'   = @\"re\"@
--     * 'SpecialCharTok'    = @\"sc\"@
--     * 'SpecialStringTok'  = @\"ss\"@
--     * 'StringTok'         = @\"st\"@
--     * 'VariableTok'       = @\"va\"@
--     * 'VerbatimStringTok' = @\"vs\"@
--     * 'WarningTok'        = @\"wa\"@
skylighting :: Extension
skylighting :: Extension
skylighting = ((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
infoString') Text
txt) ->
      let tokenizerConfig :: TokenizerConfig
tokenizerConfig =
            TokenizerConfig :: SyntaxMap -> Bool -> TokenizerConfig
S.TokenizerConfig
              { syntaxMap :: SyntaxMap
S.syntaxMap = SyntaxMap
S.defaultSyntaxMap,
                traceOutput :: Bool
S.traceOutput = Bool
False
              }
          infoString :: Text
infoString = Text -> Text -> Text -> Text
T.replace Text
"-" Text
" " Text
infoString'
       in case Text -> SyntaxMap -> Maybe Syntax
S.lookupSyntax Text
infoString SyntaxMap
S.defaultSyntaxMap of
            Maybe Syntax
Nothing -> Block (Ois, Html ()) -> Html ()
old Block (Ois, Html ())
cb
            Just Syntax
syntax ->
              case TokenizerConfig -> Syntax -> Text -> Either String [SourceLine]
S.tokenize TokenizerConfig
tokenizerConfig Syntax
syntax Text
txt of
                Left String
_ -> Block (Ois, Html ()) -> Html ()
old Block (Ois, Html ())
cb
                Right [SourceLine]
ls -> do
                  [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"source-code"]
                    (Html () -> Html ())
-> ((SourceLine -> Html ()) -> Html ())
-> (SourceLine -> 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 ())
-> ((SourceLine -> Html ()) -> Html ())
-> (SourceLine -> 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-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
infoString)]
                    (Html () -> Html ())
-> ((SourceLine -> Html ()) -> Html ())
-> (SourceLine -> Html ())
-> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SourceLine] -> (SourceLine -> Html ()) -> Html ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SourceLine]
ls
                    ((SourceLine -> Html ()) -> Html ())
-> (SourceLine -> Html ()) -> Html ()
forall a b. (a -> b) -> a -> b
$ \SourceLine
l -> do
                      (Token -> Html ()) -> SourceLine -> Html ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Token -> Html ()
tokenToHtml SourceLine
l
                      Html ()
newline
                  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 -> Html ()
tokenToHtml :: Token -> Html ()
tokenToHtml (TokenType
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 = TokenType -> Text
tokenClass TokenType
tokenType

-- | Return class corresponding to given 'TokenType'.
tokenClass :: TokenType -> Text
tokenClass :: TokenType -> Text
tokenClass = \case
  TokenType
KeywordTok -> Text
"kw"
  TokenType
DataTypeTok -> Text
"dt"
  TokenType
DecValTok -> Text
"dv"
  TokenType
BaseNTok -> Text
"bn"
  TokenType
FloatTok -> Text
"fl"
  TokenType
CharTok -> Text
"ch"
  TokenType
StringTok -> Text
"st"
  TokenType
CommentTok -> Text
"co"
  TokenType
OtherTok -> Text
"ot"
  TokenType
AlertTok -> Text
"al"
  TokenType
FunctionTok -> Text
"fu"
  TokenType
RegionMarkerTok -> Text
"re"
  TokenType
ErrorTok -> Text
"er"
  TokenType
ConstantTok -> Text
"cn"
  TokenType
SpecialCharTok -> Text
"sc"
  TokenType
VerbatimStringTok -> Text
"vs"
  TokenType
SpecialStringTok -> Text
"ss"
  TokenType
ImportTok -> Text
"im"
  TokenType
DocumentationTok -> Text
"do"
  TokenType
AnnotationTok -> Text
"an"
  TokenType
CommentVarTok -> Text
"cv"
  TokenType
VariableTok -> Text
"va"
  TokenType
ControlFlowTok -> Text
"cf"
  TokenType
OperatorTok -> Text
"op"
  TokenType
BuiltInTok -> Text
"bu"
  TokenType
ExtensionTok -> Text
"ex"
  TokenType
PreprocessorTok -> Text
"pp"
  TokenType
AttributeTok -> Text
"at"
  TokenType
InformationTok -> Text
"in"
  TokenType
WarningTok -> Text
"wa"
  TokenType
NormalTok -> Text
""