{-# LANGUAGE CPP #-}
{-# 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
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
class HasDiv bl where
div_ :: bl -> bl
instance HasDiv (Html a) where
div_ bs = htmlBlock "div" $ Just (htmlRaw "\n" <> bs)
instance (HasDiv bl, Semigroup bl)
=> HasDiv (WithSourceMap bl) where
div_ bs = (div_ <$> bs) <* addName "div"
fencedDivSpec
:: (Monad m, IsInline il, IsBlock il bl, HasDiv bl)
=> SyntaxSpec m il bl
fencedDivSpec = mempty
{ syntaxBlockSpecs = [fencedDivBlockSpec] }
fencedDivBlockSpec :: (Monad m, IsBlock il bl, HasDiv bl)
=> BlockSpec m il bl
fencedDivBlockSpec = BlockSpec
{ blockType = "FencedDiv"
, blockStart = try $ do
prepos <- getPosition
nonindentSpaces
pos <- getPosition
let indentspaces = sourceColumn pos - sourceColumn prepos
colons <- many1 (symbol ':')
let fencelength = length colons
guard $ fencelength >= 3
skipWhile (hasType Spaces)
attrs <- pAttributes
skipWhile (hasType Spaces)
lookAhead $ void lineEnd <|> eof
addNodeToStack $
Node (defBlockData fencedDivBlockSpec){
blockData = toDyn
(fencelength, indentspaces, attrs),
blockStartPos = [pos] } []
return BlockStartMatch
, blockCanContain = const True
, blockContainsLines = False
, blockParagraph = False
, blockContinue = \node -> try (do
nonindentSpaces
pos <- getPosition
ts <- many1 (symbol ':')
let closelength = length ts
skipWhile (hasType Spaces)
lookAhead $ void lineEnd <|> eof
let fencelength = getFenceLength node
guard $ closelength >= fencelength
ns <- nodeStack <$> getState
guard $ not $ any
(\n ->
(blockType (blockSpec (rootLabel n))) == "FencedDiv" &&
(getFenceLength n) <= closelength) $
takeWhile (\n -> not
(blockType (blockSpec (rootLabel n)) == "FencedDiv" &&
blockStartPos (rootLabel n) ==
blockStartPos (rootLabel node)))
ns
endOfBlock
return $! (pos, node))
<|> (do let ((_, indentspaces, _)
:: (Int, Int, Attributes)) = fromDyn
(blockData (rootLabel node))
(3, 0, mempty)
pos <- getPosition
_ <- gobbleUpToSpaces indentspaces
return $! (pos, node))
, blockConstructor = \node -> do
let ((_, _, attrs) :: (Int, Int, Attributes)) =
fromDyn (blockData (rootLabel node)) (3, 0, mempty)
(addAttributes attrs . div_ . mconcat)
<$> renderChildren node
, blockFinalize = defaultFinalizer
}
getFenceLength :: (Monad m, IsBlock il bl, HasDiv bl)
=> BlockNode m il bl -> Int
getFenceLength node =
let ((fencelength, _, _)
:: (Int, Int, Attributes)) = fromDyn
(blockData (rootLabel node))
(3, 0, mempty)
in fencelength
bracketedSpanSpec
:: (Monad m, IsInline il, HasSpan il)
=> SyntaxSpec m il bl
bracketedSpanSpec = mempty
{ syntaxBracketedSpecs = [ bsSpec ]
}
where
bsSpec = BracketedSpec
{ bracketedName = "Span"
, bracketedNests = True
, bracketedPrefix = Nothing
, bracketedSuffixEnd = Nothing
, bracketedSuffix = pSpanSuffix
}
pSpanSuffix _rm _key = do
attrs <- pAttributes
return $! spanWith attrs
class IsInline a => HasSpan a where
spanWith :: Attributes -> a -> a
instance Rangeable (Html a) => HasSpan (Html a) where
spanWith attrs ils = addAttributes attrs $ htmlInline "span" (Just ils)
instance (HasSpan i, Semigroup i, Monoid i)
=> HasSpan (WithSourceMap i) where
spanWith attrs x = (spanWith attrs <$> x) <* addName "span"
pRawSpan :: (IsInline a, Monad m) => InlineParser m a
pRawSpan = try $ do
tok <- symbol '`'
pBacktickSpan tok >>=
\case
Left ticks -> return $! str (untokenize ticks)
Right codetoks -> do
let raw = untokenize codetoks
(do f <- pRawAttribute
return $! rawInline f raw)
<|> (return $! code . normalizeCodeSpan $ raw)
rawAttributeSpec :: (Monad m, IsBlock il bl)
=> SyntaxSpec m il bl
rawAttributeSpec = mempty
{ syntaxBlockSpecs = [ rawAttributeBlockSpec ]
, syntaxInlineParsers = [ pRawSpan ]
}
rawAttributeBlockSpec :: (Monad m, IsBlock il bl)
=> BlockSpec m il bl
rawAttributeBlockSpec = BlockSpec
{ blockType = "RawBlock"
, blockStart = try $ do
prepos <- getPosition
nonindentSpaces
pos <- getPosition
let indentspaces = sourceColumn pos - sourceColumn prepos
(c, ticks) <- (('`',) <$> many1 (symbol '`'))
<|> (('~',) <$> many1 (symbol '~'))
let fencelength = length 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 = const False
, blockContainsLines = True
, blockParagraph = False
, blockContinue = \node -> try (do
let ((c, fencelength, _, _)
:: (Char, Int, Int, Format)) = fromDyn
(blockData (rootLabel node))
('`', 3, 0, Format mempty)
nonindentSpaces
pos <- getPosition
ts <- many1 (symbol c)
guard $ length ts >= fencelength
skipWhile (hasType Spaces)
lookAhead $ void lineEnd <|> eof
endOfBlock
return $! (pos, node))
<|> (do let ((_, _, indentspaces, _)
:: (Char, Int, Int, Format)) = fromDyn
(blockData (rootLabel node))
('`', 3, 0, Format mempty)
pos <- getPosition
_ <- gobbleUpToSpaces indentspaces
return $! (pos, node))
, blockConstructor = \node -> do
let ((_, _, _, fmt) :: (Char, Int, Int, Format)) =
fromDyn (blockData (rootLabel node))
('`', 3, 0, Format mempty)
let codetext = untokenize $ drop 1 (getBlockText node)
return $! rawBlock fmt codetext
, blockFinalize = defaultFinalizer
}
attributesSpec
:: (Monad m, IsInline il)
=> SyntaxSpec m il bl
attributesSpec = mempty
{ syntaxAttributeParsers = [pAttributes]
}
pAttributes :: forall u m . Monad m => ParsecT [Tok] u m Attributes
pAttributes = mconcat <$> many1 pattr
where
pattr = try $ do
symbol '{'
optional whitespace
let pAttribute = pIdentifier <|> pClass <|> pKeyValue
a <- pAttribute
as <- many $ try (whitespace *> (pIdentifier <|> pClass <|> pKeyValue))
optional whitespace
symbol '}'
return $! (a:as)
pRawAttribute :: Monad m => ParsecT [Tok] u m Format
pRawAttribute = try $ do
symbol '{'
optional whitespace
symbol '='
Tok _ _ t <- satisfyWord (const True)
optional whitespace
symbol '}'
return $! Format t
pIdentifier :: Monad m => ParsecT [Tok] u m Attribute
pIdentifier = try $ do
symbol '#'
xs <- many1 $
satisfyWord (const True)
<|> satisfyTok (\c -> hasType (Symbol '-') c || hasType (Symbol '_') c
|| hasType (Symbol ':') c || hasType (Symbol '.') c)
return $! ("id", unEntity xs)
pClass :: Monad m => ParsecT [Tok] u m Attribute
pClass = do
symbol '.'
xs <- many1 $
satisfyWord (const True)
<|> satisfyTok (\c -> hasType (Symbol '-') c || hasType (Symbol '_') c)
return $! ("class", unEntity xs)
pKeyValue :: Monad m => ParsecT [Tok] u m Attribute
pKeyValue = do
name <- htmlAttributeName
symbol '='
val <- htmlDoubleQuotedAttributeValue
<|> many1 (noneOfToks [Spaces, LineEnd, Symbol '<', Symbol '>',
Symbol '=', Symbol '`', Symbol '\'', Symbol '"',
Symbol '}'])
let val' = case val of
Tok (Symbol '"') _ _:_:_ -> drop 1 $ init $ val
Tok (Symbol '\'') _ _:_:_ -> mzero
_ -> val
return $! (untokenize name, unEntity val')