{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.MMark.Extension.Skylighting
( skylighting )
where
import Control.Monad
import Data.Semigroup ((<>))
import Data.Text (Text)
import Lucid
import Skylighting (Token, TokenType (..))
import Text.MMark.Extension (Extension, Block (..))
import qualified Data.Text as T
import qualified Skylighting as S
import qualified Text.MMark.Extension as Ext
skylighting :: Extension
skylighting = Ext.blockRender $ \old block ->
case block of
cb@(CodeBlock (Just infoString') txt) ->
let tokenizerConfig = S.TokenizerConfig
{ S.syntaxMap = S.defaultSyntaxMap
, S.traceOutput = False }
infoString = T.replace "-" " " infoString'
in case S.lookupSyntax infoString S.defaultSyntaxMap of
Nothing -> old cb
Just syntax ->
case S.tokenize tokenizerConfig syntax txt of
Left _ -> old cb
Right ls -> do
div_ [class_ "source-code"]
. pre_
. code_ [class_ ("language-" <> infoString)]
. forM_ ls $ \l -> do
mapM_ tokenToHtml l
newline
newline
other -> old other
where
newline :: Html ()
newline = "\n"
tokenToHtml :: Token -> Html ()
tokenToHtml (tokenType, txt) =
span_ [class_ rawClass | not (T.null rawClass)] (toHtml txt)
where
rawClass = tokenClass tokenType
tokenClass :: TokenType -> Text
tokenClass = \case
KeywordTok -> "kw"
DataTypeTok -> "dt"
DecValTok -> "dv"
BaseNTok -> "bn"
FloatTok -> "fl"
CharTok -> "ch"
StringTok -> "st"
CommentTok -> "co"
OtherTok -> "ot"
AlertTok -> "al"
FunctionTok -> "fu"
RegionMarkerTok -> "re"
ErrorTok -> "er"
ConstantTok -> "cn"
SpecialCharTok -> "sc"
VerbatimStringTok -> "vs"
SpecialStringTok -> "ss"
ImportTok -> "im"
DocumentationTok -> "do"
AnnotationTok -> "an"
CommentVarTok -> "cv"
VariableTok -> "va"
ControlFlowTok -> "cf"
OperatorTok -> "op"
BuiltInTok -> "bu"
ExtensionTok -> "ex"
PreprocessorTok -> "pp"
AttributeTok -> "at"
InformationTok -> "in"
WarningTok -> "wa"
NormalTok -> ""