{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Commonmark.Extensions.Math
  ( HasMath(..)
  , mathSpec )
where
import Control.Monad (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

mathSpec :: (Monad m, IsBlock il bl, IsInline il, HasMath il)
         => SyntaxSpec m il bl
mathSpec :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasMath il) =>
SyntaxSpec m il bl
mathSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxInlineParsers = [withAttributes parseMath]
  }

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

instance HasMath (Html a) where
  inlineMath :: Text -> Html a
inlineMath Text
t = Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"math inline") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
    Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"span" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\\(" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Text -> Html a
forall a. Text -> Html a
htmlText Text
t Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\\)"
  displayMath :: Text -> Html a
displayMath Text
t = Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"math display") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
    Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"span" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\\[" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Text -> Html a
forall a. Text -> Html a
htmlText Text
t Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\\]"

instance (HasMath i, Monoid i) => HasMath (WithSourceMap i) where
  inlineMath :: Text -> WithSourceMap i
inlineMath Text
t = (Text -> i
forall a. HasMath a => Text -> a
inlineMath Text
t) i -> WithSourceMap () -> WithSourceMap i
forall a b. a -> WithSourceMap b -> WithSourceMap a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> WithSourceMap ()
addName Text
"inlineMath"
  displayMath :: Text -> WithSourceMap i
displayMath Text
t = (Text -> i
forall a. HasMath a => Text -> a
displayMath Text
t) i -> WithSourceMap () -> WithSourceMap i
forall a b. a -> WithSourceMap b -> WithSourceMap a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> WithSourceMap ()
addName Text
"displayMath"

parseMath :: (Monad m, HasMath a) => InlineParser m a
parseMath :: forall (m :: * -> *) a. (Monad m, HasMath a) => InlineParser m a
parseMath = ParsecT [Tok] (IPState m) (StateT Enders m) a
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] (IPState m) (StateT Enders m) a
 -> ParsecT [Tok] (IPState m) (StateT Enders m) a)
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a b. (a -> b) -> a -> b
$ do
  Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'$'
  Bool
display <- (Bool
True Bool
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Bool
forall a b.
a
-> ParsecT [Tok] (IPState m) (StateT Enders m) b
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'$') ParsecT [Tok] (IPState m) (StateT Enders m) Bool
-> ParsecT [Tok] (IPState m) (StateT Enders m) Bool
-> ParsecT [Tok] (IPState m) (StateT Enders m) Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Bool
False Bool
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
-> ParsecT [Tok] (IPState m) (StateT Enders m) Bool
forall a b.
a
-> ParsecT [Tok] (IPState m) (StateT Enders m) b
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
-> ParsecT [Tok] (IPState m) (StateT Enders m) ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m [Tok]
whitespace)
  Text
contents <- ParsecT [Tok] (IPState m) (StateT Enders m) Text
-> ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] (IPState m) (StateT Enders m) Text
 -> ParsecT [Tok] (IPState m) (StateT Enders m) Text)
-> ParsecT [Tok] (IPState m) (StateT Enders m) Text
-> ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall a b. (a -> b) -> a -> b
$ [Tok] -> Text
untokenize ([Tok] -> Text)
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
-> ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall (m :: * -> *). Monad m => Int -> InlineParser m [Tok]
pDollarsMath Int
0
  let isWs :: Char -> Bool
isWs Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'
  if Bool
display
     then Text -> a
forall a. HasMath a => Text -> a
displayMath Text
contents a
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a b.
a
-> ParsecT [Tok] (IPState m) (StateT Enders m) b
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'$'
     else if Text -> Bool
T.null Text
contents Bool -> Bool -> Bool
|| Char -> Bool
isWs (HasCallStack => Text -> Char
Text -> Char
T.last Text
contents)
             -- don't allow math to end with SPACE + $
             then ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a. ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
             else a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a. a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ParsecT [Tok] (IPState m) (StateT Enders m) a)
-> a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a b. (a -> b) -> a -> b
$ Text -> a
forall a. HasMath a => Text -> a
inlineMath Text
contents

-- Int is number of embedded groupings
pDollarsMath :: Monad m => Int -> InlineParser m [Tok]
pDollarsMath :: forall (m :: * -> *). Monad m => Int -> InlineParser m [Tok]
pDollarsMath Int
n = do
  tk :: Tok
tk@(Tok TokType
toktype SourcePos
_ Text
_) <- ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
anyTok
  case TokType
toktype of
       Symbol Char
'$'
              | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> [Tok] -> InlineParser m [Tok]
forall a. a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
       Symbol Char
'\\' -> do
              Tok
tk' <- ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
anyTok
              (Tok
tk Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
:) ([Tok] -> [Tok]) -> ([Tok] -> [Tok]) -> [Tok] -> [Tok]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tok
tk' Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
:) ([Tok] -> [Tok]) -> InlineParser m [Tok] -> InlineParser m [Tok]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> InlineParser m [Tok]
forall (m :: * -> *). Monad m => Int -> InlineParser m [Tok]
pDollarsMath Int
n
       Symbol Char
'{' -> (Tok
tk Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
:) ([Tok] -> [Tok]) -> InlineParser m [Tok] -> InlineParser m [Tok]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> InlineParser m [Tok]
forall (m :: * -> *). Monad m => Int -> InlineParser m [Tok]
pDollarsMath (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
       Symbol Char
'}' | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> (Tok
tk Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
:) ([Tok] -> [Tok]) -> InlineParser m [Tok] -> InlineParser m [Tok]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> InlineParser m [Tok]
forall (m :: * -> *). Monad m => Int -> InlineParser m [Tok]
pDollarsMath (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                  | Bool
otherwise -> InlineParser m [Tok]
forall a. ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
       TokType
_ -> (Tok
tk Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
:) ([Tok] -> [Tok]) -> InlineParser m [Tok] -> InlineParser m [Tok]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> InlineParser m [Tok]
forall (m :: * -> *). Monad m => Int -> InlineParser m [Tok]
pDollarsMath Int
n