commonmark-extensions-0.2.7: src/Commonmark/Extensions/Math.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Commonmark.Extensions.Math
  ( HasMath(..)
  , mathSpec )
where
import Control.Monad (guard, mzero)
import Commonmark.Types
import Commonmark.Tokens
import Commonmark.Syntax
import Commonmark.Inlines
import Commonmark.SourceMap
import Commonmark.TokParsers
import Commonmark.Html
import Text.Parsec
import Data.Text (Text)
import qualified Data.Text as T
import Data.Char (isDigit)

mathSpec :: (Monad m, IsBlock il bl, IsInline il, HasMath il)
         => SyntaxSpec m il bl
mathSpec = mempty
  { syntaxInlineParsers = [withAttributes parseMath]
  }

class HasMath a where
  inlineMath :: Text -> a
  displayMath :: Text -> a

instance HasMath (Html a) where
  inlineMath t = addAttribute ("class", "math inline") $
    htmlInline "span" $ Just $ htmlRaw "\\(" <> htmlText t <> htmlRaw "\\)"
  displayMath t = addAttribute ("class", "math display") $
    htmlInline "span" $ Just $ htmlRaw "\\[" <> htmlText t <> htmlRaw "\\]"

instance (HasMath i, Monoid i) => HasMath (WithSourceMap i) where
  inlineMath t = (inlineMath t) <$ addName "inlineMath"
  displayMath t = (displayMath t) <$ addName "displayMath"

parseMath :: (Monad m, HasMath a) => InlineParser m a
parseMath = try $ do
  symbol '$'
  display <- (True <$ symbol '$') <|> (False <$ notFollowedBy whitespace)
  contents <- try $ untokenize <$> pDollarsMath 0
  let isWs c = c == ' ' || c == '\t' || c == '\r' || c == '\n'
  if display
     then displayMath contents <$ symbol '$'
     else do
             -- don't allow empty inline math
             guard $ not $ T.null contents
             -- don't allow inline math to end with SPACE + $
             guard $ not $ isWs $ T.last contents
             -- don't allow the closer followed by numbers ($5)
             let startsWithDigit = maybe False (isDigit . fst) . T.uncons
             notFollowedBy $ satisfyWord startsWithDigit
             pure $ inlineMath contents

-- Int is number of embedded groupings
pDollarsMath :: Monad m => Int -> InlineParser m [Tok]
pDollarsMath n = do
  guard (n <= 1000) -- bail on pathological inputs
  tk@(Tok toktype _ _) <- anyTok
  case toktype of
       Symbol '$'
              | n == 0 -> return []
       Symbol '\\' -> do
              tk' <- anyTok
              (tk :) . (tk' :) <$> pDollarsMath n
       Symbol '{' -> (tk :) <$> pDollarsMath (n+1)
       Symbol '}' | n > 0 -> (tk :) <$> pDollarsMath (n-1)
                  | otherwise -> mzero
       _ -> (tk :) <$> pDollarsMath n