{-# 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
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)
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
}
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')