{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
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
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"
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
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
""