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

module Reflex.Dom.Pandoc.SyntaxHighlighting where

import Control.Monad (forM_, msum)
import Data.Text (Text)
import Reflex.Dom.Core
import Reflex.Dom.Pandoc.Util (elPandocAttr)
import qualified Skylighting as S
import Text.Pandoc.Definition (Attr)
import Prelude hiding (lines)

elCodeHighlighted ::
  forall t m.
  DomBuilder t m =>
  -- | Pandoc attribute object. TODO: Use a sensible type.
  Attr ->
  -- | Code to highlight.
  Text ->
  m ()
elCodeHighlighted :: Attr -> Text -> m ()
elCodeHighlighted attr :: Attr
attr@(Text
_, [Text]
langClasses, [(Text, Text)]
_) Text
x = do
  case [Text] -> Text -> Maybe [SourceLine]
forall (t :: * -> *).
(Foldable t, Functor t) =>
t Text -> Text -> Maybe [SourceLine]
tokenizeForOneOfLang [Text]
langClasses Text
x of
    Maybe [SourceLine]
Nothing -> do
      Text -> m () -> m ()
forall t (m :: * -> *) a. DomBuilder t m => Text -> m a -> m a
divClass Text
"pandoc-code nosyntax" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> m () -> m ()
forall t (m :: * -> *) a. DomBuilder t m => Text -> m a -> m a
el Text
"pre" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          Text -> Attr -> m () -> m ()
forall t (m :: * -> *) a.
DomBuilder t m =>
Text -> Attr -> m a -> m a
elPandocAttr Text
"code" Attr
attr (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            Text -> m ()
forall t (m :: * -> *). DomBuilder t m => Text -> m ()
text Text
x
    Just [SourceLine]
lines ->
      Text -> m () -> m ()
forall t (m :: * -> *) a. DomBuilder t m => Text -> m a -> m a
divClass Text
"pandoc-code highlighted" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> m () -> m ()
forall t (m :: * -> *) a. DomBuilder t m => Text -> m a -> m a
el Text
"pre" (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          Text -> Attr -> m () -> m ()
forall t (m :: * -> *) a.
DomBuilder t m =>
Text -> Attr -> m a -> m a
elPandocAttr Text
"code" Attr
attr (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            [SourceLine] -> (SourceLine -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SourceLine]
lines ((SourceLine -> m ()) -> m ()) -> (SourceLine -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \SourceLine
line -> do
              SourceLine -> (Token -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ SourceLine
line ((Token -> m ()) -> m ()) -> (Token -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(TokenType
tokType, Text
tok) ->
                Text -> Text -> m () -> m ()
forall t (m :: * -> *) a.
DomBuilder t m =>
Text -> Text -> m a -> m a
elClass Text
"span" (TokenType -> Text
tokenClass TokenType
tokType) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall t (m :: * -> *). DomBuilder t m => Text -> m ()
text Text
tok
              Text -> m ()
forall t (m :: * -> *). DomBuilder t m => Text -> m ()
text Text
"\n"
  where
    tokenizeForOneOfLang :: t Text -> Text -> Maybe [SourceLine]
tokenizeForOneOfLang t Text
langs Text
s = do
      Syntax
syntax <- t (Maybe Syntax) -> Maybe Syntax
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((Text -> Maybe Syntax) -> t Text -> t (Maybe Syntax)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> SyntaxMap -> Maybe Syntax
`S.lookupSyntax` SyntaxMap
S.defaultSyntaxMap) t Text
langs)
      case TokenizerConfig -> Syntax -> Text -> Either String [SourceLine]
S.tokenize TokenizerConfig
tokenizerConfig Syntax
syntax Text
s of
        Left String
_ -> Maybe [SourceLine]
forall a. Maybe a
Nothing
        Right [SourceLine]
lines -> [SourceLine] -> Maybe [SourceLine]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [SourceLine]
lines
    tokenizerConfig :: TokenizerConfig
tokenizerConfig =
      TokenizerConfig :: SyntaxMap -> Bool -> TokenizerConfig
S.TokenizerConfig
        { syntaxMap :: SyntaxMap
S.syntaxMap = SyntaxMap
S.defaultSyntaxMap,
          traceOutput :: Bool
S.traceOutput = Bool
False
        }

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