{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
module Commonmark.Extensions.Attributes
  ( attributesSpec
  , HasDiv(..)
  , fencedDivSpec
  , HasSpan(..)
  , bracketedSpanSpec
  , rawAttributeSpec
  , pAttributes
  )
where
import Commonmark.Types
import Commonmark.Tag (htmlAttributeName, htmlDoubleQuotedAttributeValue)
import Commonmark.Tokens
import Commonmark.Syntax
import Commonmark.Inlines
import Commonmark.TokParsers
import Commonmark.SourceMap
import Commonmark.Blocks
import Commonmark.Entity (unEntity)
import Commonmark.Html
import Data.Dynamic
import Data.Tree
import Control.Monad (mzero, guard, void)
import Text.Parsec

class HasDiv bl where
  div_ :: bl -> bl

instance HasDiv (Html a) where
  div_ :: Html a -> Html a
div_ Html a
bs = Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"div" (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 (Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\n" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Html a
bs)

instance (HasDiv bl, Semigroup bl)
        => HasDiv (WithSourceMap bl) where
  div_ :: WithSourceMap bl -> WithSourceMap bl
div_ WithSourceMap bl
bs = (bl -> bl
forall bl. HasDiv bl => bl -> bl
div_ (bl -> bl) -> WithSourceMap bl -> WithSourceMap bl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap bl
bs) WithSourceMap bl -> WithSourceMap () -> WithSourceMap bl
forall a b. WithSourceMap a -> WithSourceMap b -> WithSourceMap a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"div"

fencedDivSpec
             :: (Monad m, IsInline il, IsBlock il bl, HasDiv bl)
             => SyntaxSpec m il bl
fencedDivSpec :: forall (m :: * -> *) il bl.
(Monad m, IsInline il, IsBlock il bl, HasDiv bl) =>
SyntaxSpec m il bl
fencedDivSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxBlockSpecs = [fencedDivBlockSpec] }

fencedDivBlockSpec :: (Monad m, IsBlock il bl, HasDiv bl)
                   => BlockSpec m il bl
fencedDivBlockSpec :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, HasDiv bl) =>
BlockSpec m il bl
fencedDivBlockSpec = BlockSpec
    { blockType :: Text
blockType           = Text
"FencedDiv"
     , blockStart :: BlockParser m il bl BlockStartResult
blockStart          = BlockParser m il bl BlockStartResult
-> BlockParser m il bl BlockStartResult
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (BlockParser m il bl BlockStartResult
 -> BlockParser m il bl BlockStartResult)
-> BlockParser m il bl BlockStartResult
-> BlockParser m il bl BlockStartResult
forall a b. (a -> b) -> a -> b
$ do
             prepos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
             nonindentSpaces
             pos <- getPosition
             let indentspaces = SourcePos -> Int
sourceColumn SourcePos
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- SourcePos -> Int
sourceColumn SourcePos
prepos
             colons <- many1 (symbol ':')
             let fencelength = [Tok] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok]
colons
             guard $ fencelength >= 3
             skipWhile (hasType Spaces)
             attrs <- pAttributes <|>
                      (do bareWordToks <- many1
                           (satisfyWord (const True) <|> anySymbol)
                          return [("class", untokenize bareWordToks)])
             skipWhile (hasType Spaces)
             lookAhead $ void lineEnd <|> eof
             addNodeToStack $
                Node (defBlockData fencedDivBlockSpec){
                          blockData = toDyn
                               (fencelength, indentspaces, attrs),
                          blockStartPos = [pos] } []
             return BlockStartMatch
     , blockCanContain :: BlockSpec m il bl -> Bool
blockCanContain     = Bool -> BlockSpec m il bl -> Bool
forall a b. a -> b -> a
const Bool
True
     , blockContainsLines :: Bool
blockContainsLines  = Bool
False
     , blockParagraph :: Bool
blockParagraph      = Bool
False
     , blockContinue :: BlockNode m il bl
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
blockContinue       = \BlockNode m il bl
node -> BlockParser m il bl (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (do
             ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m ()
nonindentSpaces
             pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
             ts <- many1 (symbol ':')
             let closelength = [Tok] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok]
ts
             skipWhile (hasType Spaces)
             lookAhead $ void lineEnd <|> eof
             let fencelength = BlockNode m il bl -> Int
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, HasDiv bl) =>
BlockNode m il bl -> Int
getFenceLength BlockNode m il bl
node
             guard $ closelength >= fencelength
             -- ensure that there aren't subordinate open fenced divs
             -- with fencelength <= closelength:
             ns <- nodeStack <$> getState
             guard $ not $ any
               (\BlockNode m il bl
n ->
                 (BlockSpec m il bl -> Text
forall (m :: * -> *) il bl. BlockSpec m il bl -> Text
blockType (BlockData m il bl -> BlockSpec m il bl
forall (m :: * -> *) il bl. BlockData m il bl -> BlockSpec m il bl
blockSpec (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
n))) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"FencedDiv" Bool -> Bool -> Bool
&&
                 (BlockNode m il bl -> Int
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, HasDiv bl) =>
BlockNode m il bl -> Int
getFenceLength BlockNode m il bl
n) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
closelength) $
               takeWhile (\BlockNode m il bl
n -> Bool -> Bool
not
                    (BlockSpec m il bl -> Text
forall (m :: * -> *) il bl. BlockSpec m il bl -> Text
blockType (BlockData m il bl -> BlockSpec m il bl
forall (m :: * -> *) il bl. BlockData m il bl -> BlockSpec m il bl
blockSpec (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
n)) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"FencedDiv" Bool -> Bool -> Bool
&&
                     BlockData m il bl -> [SourcePos]
forall (m :: * -> *) il bl. BlockData m il bl -> [SourcePos]
blockStartPos (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
n) [SourcePos] -> [SourcePos] -> Bool
forall a. Eq a => a -> a -> Bool
==
                     BlockData m il bl -> [SourcePos]
forall (m :: * -> *) il bl. BlockData m il bl -> [SourcePos]
blockStartPos (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
node)))
               ns
             endOfBlock
             return $! (pos, node))
               BlockParser m il bl (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (do let ((Int
_, Int
indentspaces, Attributes
_)
                              :: (Int, Int, Attributes)) = Dynamic -> (Int, Int, Attributes) -> (Int, Int, Attributes)
forall a. Typeable a => Dynamic -> a -> a
fromDyn
                                   (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
node))
                                   (Int
3, Int
0, Attributes
forall a. Monoid a => a
mempty)
                       pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
                       _ <- gobbleUpToSpaces indentspaces
                       return $! (pos, node))
     , blockConstructor :: BlockNode m il bl -> BlockParser m il bl bl
blockConstructor    = \BlockNode m il bl
node -> do
           let ((Int
_, Int
_, Attributes
attrs) :: (Int, Int, Attributes)) =
                   Dynamic -> (Int, Int, Attributes) -> (Int, Int, Attributes)
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
node)) (Int
3, Int
0, Attributes
forall a. Monoid a => a
mempty)
           (Attributes -> bl -> bl
forall a. HasAttributes a => Attributes -> a -> a
addAttributes Attributes
attrs (bl -> bl) -> ([bl] -> bl) -> [bl] -> bl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. bl -> bl
forall bl. HasDiv bl => bl -> bl
div_ (bl -> bl) -> ([bl] -> bl) -> [bl] -> bl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [bl] -> bl
forall a. Monoid a => [a] -> a
mconcat)
             ([bl] -> bl)
-> ParsecT [Tok] (BPState m il bl) m [bl] -> BlockParser m il bl bl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m [bl]
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl) =>
BlockNode m il bl -> BlockParser m il bl [bl]
renderChildren BlockNode m il bl
node
     , blockFinalize :: BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
blockFinalize       = BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
forall (m :: * -> *) il bl.
Monad m =>
BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
defaultFinalizer
     }

getFenceLength :: (Monad m, IsBlock il bl, HasDiv bl)
               => BlockNode m il bl -> Int
getFenceLength :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, HasDiv bl) =>
BlockNode m il bl -> Int
getFenceLength BlockNode m il bl
node =
  let ((Int
fencelength, Int
_, Attributes
_)
         :: (Int, Int, Attributes)) = Dynamic -> (Int, Int, Attributes) -> (Int, Int, Attributes)
forall a. Typeable a => Dynamic -> a -> a
fromDyn
                        (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
node))
                        (Int
3, Int
0, Attributes
forall a. Monoid a => a
mempty)
  in Int
fencelength

bracketedSpanSpec
             :: (Monad m, IsInline il, HasSpan il)
             => SyntaxSpec m il bl
bracketedSpanSpec :: forall (m :: * -> *) il bl.
(Monad m, IsInline il, HasSpan il) =>
SyntaxSpec m il bl
bracketedSpanSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxBracketedSpecs = [ bsSpec ]
  }
  where
   bsSpec :: BracketedSpec il
bsSpec = BracketedSpec
            { bracketedName :: Text
bracketedName = Text
"Span"
            , bracketedNests :: Bool
bracketedNests = Bool
True
            , bracketedPrefix :: Maybe Char
bracketedPrefix = Maybe Char
forall a. Maybe a
Nothing
            , bracketedSuffixEnd :: Maybe Char
bracketedSuffixEnd = Maybe Char
forall a. Maybe a
Nothing
            , bracketedSuffix :: ReferenceMap -> Text -> Parsec [Tok] () (il -> il)
bracketedSuffix = ReferenceMap -> Text -> Parsec [Tok] () (il -> il)
forall {m :: * -> *} {a} {p} {p} {u}.
(Monad m, HasSpan a) =>
p -> p -> ParsecT [Tok] u m (a -> a)
pSpanSuffix
            }
   pSpanSuffix :: p -> p -> ParsecT [Tok] u m (a -> a)
pSpanSuffix p
_rm p
_key = do
     attrs <- ParsecT [Tok] u m Attributes
forall u (m :: * -> *). Monad m => ParsecT [Tok] u m Attributes
pAttributes
     return $! spanWith attrs

class IsInline a => HasSpan a where
  spanWith :: Attributes -> a -> a

instance Rangeable (Html a) => HasSpan (Html a) where
  spanWith :: Attributes -> Html a -> Html a
spanWith Attributes
attrs Html a
ils = Attributes -> Html a -> Html a
forall a. HasAttributes a => Attributes -> a -> a
addAttributes Attributes
attrs (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" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
ils)

instance (HasSpan i, Semigroup i, Monoid i)
        => HasSpan (WithSourceMap i) where
  spanWith :: Attributes -> WithSourceMap i -> WithSourceMap i
spanWith Attributes
attrs WithSourceMap i
x = (Attributes -> i -> i
forall a. HasSpan a => Attributes -> a -> a
spanWith Attributes
attrs (i -> i) -> WithSourceMap i -> WithSourceMap i
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap i
x) WithSourceMap i -> WithSourceMap () -> WithSourceMap i
forall a b. WithSourceMap a -> WithSourceMap b -> WithSourceMap a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"span"

pRawSpan :: (IsInline a, Monad m) => InlineParser m a
pRawSpan :: forall a (m :: * -> *). (IsInline a, Monad m) => InlineParser m a
pRawSpan = 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
  tok <- Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'`'
  pBacktickSpan tok >>=
   \case
    Left [Tok]
ticks     -> 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. IsInline a => Text -> a
str ([Tok] -> Text
untokenize [Tok]
ticks)
    Right [Tok]
codetoks -> do
      let raw :: Text
raw = [Tok] -> Text
untokenize [Tok]
codetoks
      (do f <- ParsecT [Tok] (IPState m) (StateT Enders m) Format
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Format
pRawAttribute
          return $! rawInline f raw)
       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 s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (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. IsInline a => Text -> a
code (Text -> a) -> (Text -> Text) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
normalizeCodeSpan (Text -> a) -> Text -> a
forall a b. (a -> b) -> a -> b
$ Text
raw)

rawAttributeSpec :: (Monad m, IsBlock il bl)
                         => SyntaxSpec m il bl
rawAttributeSpec :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl) =>
SyntaxSpec m il bl
rawAttributeSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxBlockSpecs = [ rawAttributeBlockSpec ]
  , syntaxInlineParsers = [ pRawSpan ]
  }

rawAttributeBlockSpec :: (Monad m, IsBlock il bl)
                              => BlockSpec m il bl
rawAttributeBlockSpec :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl) =>
BlockSpec m il bl
rawAttributeBlockSpec = BlockSpec
     { blockType :: Text
blockType           = Text
"RawBlock"
     , blockStart :: BlockParser m il bl BlockStartResult
blockStart          = BlockParser m il bl BlockStartResult
-> BlockParser m il bl BlockStartResult
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (BlockParser m il bl BlockStartResult
 -> BlockParser m il bl BlockStartResult)
-> BlockParser m il bl BlockStartResult
-> BlockParser m il bl BlockStartResult
forall a b. (a -> b) -> a -> b
$ do
             prepos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
             nonindentSpaces
             pos <- getPosition
             let indentspaces = SourcePos -> Int
sourceColumn SourcePos
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- SourcePos -> Int
sourceColumn SourcePos
prepos
             (c, ticks) <-  (('`',) <$> many1 (symbol '`'))
                        <|> (('~',) <$> many1 (symbol '~'))
             let fencelength = [Tok] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tok]
ticks
             guard $ fencelength >= 3
             skipWhile (hasType Spaces)
             fmt <- pRawAttribute
             skipWhile (hasType Spaces)
             lookAhead $ void lineEnd <|> eof
             addNodeToStack $
                Node (defBlockData rawAttributeBlockSpec){
                          blockData = toDyn
                               (c, fencelength, indentspaces, fmt),
                          blockStartPos = [pos] } []
             return BlockStartMatch
     , blockCanContain :: BlockSpec m il bl -> Bool
blockCanContain     = Bool -> BlockSpec m il bl -> Bool
forall a b. a -> b -> a
const Bool
False
     , blockContainsLines :: Bool
blockContainsLines  = Bool
True
     , blockParagraph :: Bool
blockParagraph      = Bool
False
     , blockContinue :: BlockNode m il bl
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
blockContinue       = \BlockNode m il bl
node -> BlockParser m il bl (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (do
             let ((Char
c, Int
fencelength, Int
_, Format
_)
                    :: (Char, Int, Int, Format)) = Dynamic -> (Char, Int, Int, Format) -> (Char, Int, Int, Format)
forall a. Typeable a => Dynamic -> a -> a
fromDyn
                                   (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
node))
                                   (Char
'`', Int
3, Int
0, Text -> Format
Format Text
forall a. Monoid a => a
mempty)
             ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m ()
nonindentSpaces
             pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
             ts <- many1 (symbol c)
             guard $ length ts >= fencelength
             skipWhile (hasType Spaces)
             lookAhead $ void lineEnd <|> eof
             endOfBlock
             return $! (pos, node))
               BlockParser m il bl (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (do let ((Char
_, Int
_, Int
indentspaces, Format
_)
                              :: (Char, Int, Int, Format)) = Dynamic -> (Char, Int, Int, Format) -> (Char, Int, Int, Format)
forall a. Typeable a => Dynamic -> a -> a
fromDyn
                                   (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
node))
                                   (Char
'`', Int
3, Int
0, Text -> Format
Format Text
forall a. Monoid a => a
mempty)
                       pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
                       _ <- gobbleUpToSpaces indentspaces
                       return $! (pos, node))
     , blockConstructor :: BlockNode m il bl -> BlockParser m il bl bl
blockConstructor    = \BlockNode m il bl
node -> do
           let ((Char
_, Int
_, Int
_, Format
fmt) :: (Char, Int, Int, Format)) =
                   Dynamic -> (Char, Int, Int, Format) -> (Char, Int, Int, Format)
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
node))
                     (Char
'`', Int
3, Int
0, Text -> Format
Format Text
forall a. Monoid a => a
mempty)
           let codetext :: Text
codetext = [Tok] -> Text
untokenize ([Tok] -> Text) -> [Tok] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Tok] -> [Tok]
forall a. Int -> [a] -> [a]
drop Int
1 (BlockNode m il bl -> [Tok]
forall (m :: * -> *) il bl. BlockNode m il bl -> [Tok]
getBlockText BlockNode m il bl
node)
           -- drop 1 initial lineend token
           bl -> BlockParser m il bl bl
forall a. a -> ParsecT [Tok] (BPState m il bl) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (bl -> BlockParser m il bl bl) -> bl -> BlockParser m il bl bl
forall a b. (a -> b) -> a -> b
$! Format -> Text -> bl
forall il b. IsBlock il b => Format -> Text -> b
rawBlock Format
fmt Text
codetext
     , blockFinalize :: BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
blockFinalize       = BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
forall (m :: * -> *) il bl.
Monad m =>
BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
defaultFinalizer
     }

-- | Allow attributes on everything.
attributesSpec
             :: (Monad m, IsInline il)
             => SyntaxSpec m il bl
attributesSpec :: forall (m :: * -> *) il bl.
(Monad m, IsInline il) =>
SyntaxSpec m il bl
attributesSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxAttributeParsers = [pAttributes]
  }

pAttributes :: forall u m . Monad m => ParsecT [Tok] u m Attributes
pAttributes :: forall u (m :: * -> *). Monad m => ParsecT [Tok] u m Attributes
pAttributes = [Attributes] -> Attributes
forall a. Monoid a => [a] -> a
mconcat ([Attributes] -> Attributes)
-> ParsecT [Tok] u m [Attributes] -> ParsecT [Tok] u m Attributes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] u m Attributes -> ParsecT [Tok] u m [Attributes]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT [Tok] u m Attributes
forall {u}. ParsecT [Tok] u m Attributes
pattr
  where
    pattr :: ParsecT [Tok] u m Attributes
pattr = ParsecT [Tok] u m Attributes -> ParsecT [Tok] u m Attributes
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] u m Attributes -> ParsecT [Tok] u m Attributes)
-> ParsecT [Tok] u m Attributes -> ParsecT [Tok] u m Attributes
forall a b. (a -> b) -> a -> b
$ do
      Char -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'{'
      ParsecT [Tok] u m [Tok] -> ParsecT [Tok] u m ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional ParsecT [Tok] u m [Tok]
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m [Tok]
whitespace
      let pAttribute :: ParsecT [Tok] u m Attribute
pAttribute = ParsecT [Tok] u m Attribute
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Attribute
pIdentifier ParsecT [Tok] u m Attribute
-> ParsecT [Tok] u m Attribute -> ParsecT [Tok] u m Attribute
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Tok] u m Attribute
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Attribute
pClass ParsecT [Tok] u m Attribute
-> ParsecT [Tok] u m Attribute -> ParsecT [Tok] u m Attribute
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Tok] u m Attribute
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Attribute
pKeyValue
      a <- ParsecT [Tok] u m Attribute
forall {u}. ParsecT [Tok] u m Attribute
pAttribute
      as <- many $ try (whitespace *> (pIdentifier <|> pClass <|> pKeyValue))
      optional whitespace
      symbol '}'
      return $! (a:as)

pRawAttribute :: Monad m => ParsecT [Tok] u m Format
pRawAttribute :: forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Format
pRawAttribute = ParsecT [Tok] u m Format -> ParsecT [Tok] u m Format
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] u m Format -> ParsecT [Tok] u m Format)
-> ParsecT [Tok] u m Format -> ParsecT [Tok] u m Format
forall a b. (a -> b) -> a -> b
$ do
  Char -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'{'
  ParsecT [Tok] u m [Tok] -> ParsecT [Tok] u m ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional ParsecT [Tok] u m [Tok]
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m [Tok]
whitespace
  Char -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'='
  Tok _ _ t <- (Text -> Bool) -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
True)
  optional whitespace
  symbol '}'
  return $! Format t

pIdentifier :: Monad m => ParsecT [Tok] u m Attribute
pIdentifier :: forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Attribute
pIdentifier = ParsecT [Tok] u m Attribute -> ParsecT [Tok] u m Attribute
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] u m Attribute -> ParsecT [Tok] u m Attribute)
-> ParsecT [Tok] u m Attribute -> ParsecT [Tok] u m Attribute
forall a b. (a -> b) -> a -> b
$ do
  Char -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'#'
  xs <- ParsecT [Tok] u m Tok -> ParsecT [Tok] u m [Tok]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Tok] u m Tok -> ParsecT [Tok] u m [Tok])
-> ParsecT [Tok] u m Tok -> ParsecT [Tok] u m [Tok]
forall a b. (a -> b) -> a -> b
$
        (Text -> Bool) -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
True)
    ParsecT [Tok] u m Tok
-> ParsecT [Tok] u m Tok -> ParsecT [Tok] u m Tok
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Tok -> Bool) -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (\Tok
c -> TokType -> Tok -> Bool
hasType (Char -> TokType
Symbol Char
'-') Tok
c Bool -> Bool -> Bool
|| TokType -> Tok -> Bool
hasType (Char -> TokType
Symbol Char
'_') Tok
c
                        Bool -> Bool -> Bool
|| TokType -> Tok -> Bool
hasType (Char -> TokType
Symbol Char
':') Tok
c Bool -> Bool -> Bool
|| TokType -> Tok -> Bool
hasType (Char -> TokType
Symbol Char
'.') Tok
c)
  return $! ("id", unEntity xs)

pClass :: Monad m => ParsecT [Tok] u m Attribute
pClass :: forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Attribute
pClass = do
  Char -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'.'
  xs <- ParsecT [Tok] u m Tok -> ParsecT [Tok] u m [Tok]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Tok] u m Tok -> ParsecT [Tok] u m [Tok])
-> ParsecT [Tok] u m Tok -> ParsecT [Tok] u m [Tok]
forall a b. (a -> b) -> a -> b
$
        (Text -> Bool) -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
True)
    ParsecT [Tok] u m Tok
-> ParsecT [Tok] u m Tok -> ParsecT [Tok] u m Tok
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Tok -> Bool) -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] s m Tok
satisfyTok (\Tok
c -> TokType -> Tok -> Bool
hasType (Char -> TokType
Symbol Char
'-') Tok
c Bool -> Bool -> Bool
|| TokType -> Tok -> Bool
hasType (Char -> TokType
Symbol Char
'_') Tok
c)
  return $! ("class", unEntity xs)

pKeyValue :: Monad m => ParsecT [Tok] u m Attribute
pKeyValue :: forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Attribute
pKeyValue = do
  name <- ParsecT [Tok] u m [Tok]
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m [Tok]
htmlAttributeName
  symbol '='
  val <- htmlDoubleQuotedAttributeValue
       <|> many1 (noneOfToks [Spaces, LineEnd, Symbol '<', Symbol '>',
                      Symbol '=', Symbol '`', Symbol '\'', Symbol '"',
                      Symbol '}'])
  let val' = case [Tok]
val of
               Tok (Symbol Char
'"') SourcePos
_ Text
_:Tok
_:[Tok]
_  -> Int -> [Tok] -> [Tok]
forall a. Int -> [a] -> [a]
drop Int
1 ([Tok] -> [Tok]) -> [Tok] -> [Tok]
forall a b. (a -> b) -> a -> b
$ [Tok] -> [Tok]
forall a. HasCallStack => [a] -> [a]
init ([Tok] -> [Tok]) -> [Tok] -> [Tok]
forall a b. (a -> b) -> a -> b
$ [Tok]
val
               Tok (Symbol Char
'\'') SourcePos
_ Text
_:Tok
_:[Tok]
_ -> [Tok]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
               [Tok]
_ -> [Tok]
val
  return $! (untokenize name, unEntity val')