diff --git a/commonmark-cli/src/convert.hs b/commonmark-cli/src/convert.hs index adea33c..8c34e1c 100644 --- a/commonmark-cli/src/convert.hs +++ b/commonmark-cli/src/convert.hs @@ -134,6 +134,7 @@ extensions :: (Monad m, Typeable m, HasStrikethrough il, HasSuperscript il, HasSubscript il, + HasCitations il, HasDefinitionList il bl, HasDiv bl, HasTaskList il bl, @@ -146,6 +147,7 @@ extensions = ,("strikethrough", strikethroughSpec) ,("superscript", superscriptSpec) ,("subscript", subscriptSpec) + ,("citations", citationsSpec) ,("smart", smartPunctuationSpec) ,("math", mathSpec) ,("emoji", emojiSpec) @@ -184,6 +186,7 @@ specFromExtensionNames :: HasStrikethrough il, HasSuperscript il, HasSubscript il, + HasCitations il, HasDefinitionList il bl, HasDiv bl, HasTaskList il bl, diff --git a/commonmark-extensions/commonmark-extensions.cabal b/commonmark-extensions/commonmark-extensions.cabal index 1a38fa4..be4705e 100644 --- a/commonmark-extensions/commonmark-extensions.cabal +++ b/commonmark-extensions/commonmark-extensions.cabal @@ -82,6 +82,7 @@ library Commonmark.Extensions.ImplicitHeadingReferences Commonmark.Extensions.RebaseRelativePaths Commonmark.Extensions.Wikilinks + Commonmark.Extensions.Citations ghc-options: -Wall -fno-warn-unused-do-bind -funbox-small-strict-fields if impl(ghc >= 8.10) ghc-options: -Wunused-packages diff --git a/commonmark-extensions/src/Commonmark/Extensions.hs b/commonmark-extensions/src/Commonmark/Extensions.hs index 4aefbf6..692d2d8 100644 --- a/commonmark-extensions/src/Commonmark/Extensions.hs +++ b/commonmark-extensions/src/Commonmark/Extensions.hs @@ -40,6 +40,7 @@ module Commonmark.Extensions , module Commonmark.Extensions.ImplicitHeadingReferences , module Commonmark.Extensions.Wikilinks , module Commonmark.Extensions.RebaseRelativePaths + , module Commonmark.Extensions.Citations , gfmExtensions ) where @@ -61,6 +62,7 @@ import Commonmark.Extensions.TaskList import Commonmark.Extensions.ImplicitHeadingReferences import Commonmark.Extensions.Wikilinks import Commonmark.Extensions.RebaseRelativePaths +import Commonmark.Extensions.Citations import Commonmark import Data.Typeable @@ -73,4 +75,3 @@ gfmExtensions :: (Monad m, Typeable m, Typeable il, Typeable bl, gfmExtensions = emojiSpec <> strikethroughSpec <> pipeTableSpec <> autolinkSpec <> autoIdentifiersSpec <> taskListSpec <> footnoteSpec - diff --git a/commonmark-extensions/src/Commonmark/Extensions/Citations.hs b/commonmark-extensions/src/Commonmark/Extensions/Citations.hs new file mode 100644 index 0000000..60b92d4 --- /dev/null +++ b/commonmark-extensions/src/Commonmark/Extensions/Citations.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +module Commonmark.Extensions.Citations + ( HasCitations(..), + citationsSpec + ) +where +import Commonmark.Types +import Commonmark.Tokens +import Commonmark.Syntax +import Commonmark.Inlines +import Commonmark.SourceMap ( addName, WithSourceMap, runWithSourceMap ) +import Commonmark.Html ( htmlInline, addAttribute, Html(..), ElementType(..) ) +import Commonmark.TokParsers +import Control.Monad (guard) +import Data.Text (Text) +import Text.Parsec + +class HasCitations il where + citationGroup :: il -> il -- we'll parse further in pandoc + citation :: Text -> Bool -> il + hasCitations :: il -> Bool + +instance HasCitations (Html il) where + citationGroup = + addAttribute ("class", "citation-group") . + htmlInline "span" . + Just + citation ident suppressAuthor = + addAttribute ("class", "citation") . + addAttribute ("identifier", ident) . + (if suppressAuthor + then addAttribute ("suppress-author", "true") + else id) $ + htmlInline "span" Nothing + hasCitations x = case x of + HtmlElement InlineElement "span" attr _ -> + lookup "class" attr == Just "citation" + HtmlConcat w v -> hasCitations w || hasCitations v + _ -> False + +instance (HasCitations il, Monoid il, Show il) => HasCitations (WithSourceMap il) where + citationGroup x = (citationGroup <$> x) <* addName "citation" + citation ident suppressAuthor = + pure (citation ident suppressAuthor) <* addName "citation" + hasCitations x = + let (x', _) = runWithSourceMap x + in hasCitations x' + +citationsSpec + :: forall m bl il . (Monad m , IsInline il , IsBlock il bl, HasCitations il) + => SyntaxSpec m il bl +citationsSpec = + defaultSyntaxSpec { + syntaxBracketedSpecs = [citationBracketedSpec] + , syntaxInlineParsers = [withAttributes parseBareCitation] } + + where + + citationBracketedSpec :: BracketedSpec il + citationBracketedSpec = BracketedSpec + { bracketedName = "Citation" + , bracketedNests = True + , bracketedPrefix = Nothing + , bracketedSuffixEnd = Just ';' + -- causes ; to be parsed in own chunk + , bracketedSuffix = checkCitation + } + + checkCitation _rm chunksInside = do + -- if there are bare citations inside, return citation + let chunkHasCitations c = + case chunkType c of + Parsed x -> hasCitations x + _ -> False + guard $ any chunkHasCitations chunksInside + return $! citationGroup + +parseBareCitation :: (Monad m, HasCitations il, IsInline il) + => InlineParser m il +parseBareCitation = do + suppressAuthor <- (True <$ symbol '-') <|> pure False + ident <- parseCitationId + return $! citation ident suppressAuthor + +parseCitationId :: Monad m => InlineParser m Text +parseCitationId = try $ do + symbol '@' + untokenize <$> + (many1 (satisfyTok (\t -> case tokType t of + Symbol c -> c `elem` ['_'] + WordChars -> True + _ -> False))) diff --git a/commonmark-extensions/src/Commonmark/Extensions/RebaseRelativePaths.hs b/commonmark-extensions/src/Commonmark/Extensions/RebaseRelativePaths.hs index cbfe531..50a2acd 100644 --- a/commonmark-extensions/src/Commonmark/Extensions/RebaseRelativePaths.hs +++ b/commonmark-extensions/src/Commonmark/Extensions/RebaseRelativePaths.hs @@ -7,6 +7,7 @@ where import Commonmark.Types import Commonmark.Syntax import Commonmark.Inlines +import Commonmark.Tokens import Data.Text (Text) import qualified Data.Text as T import Data.Maybe (fromMaybe) @@ -45,14 +46,16 @@ rebaseRelativePathsSpec = , bracketedSuffix = newLinkSuffix } - newImageSuffix rm key = do + newImageSuffix rm chunksInside = do pos <- getPosition + let key = untokenize $ concatMap chunkToks chunksInside LinkInfo target title attrs mbpos <- pLink rm key let pos' = fromMaybe pos mbpos return $! addAttributes attrs . image (rebasePath pos' target) title - newLinkSuffix rm key = do + newLinkSuffix rm chunksInside = do pos <- getPosition + let key = untokenize $ concatMap chunkToks chunksInside LinkInfo target title attrs mbpos <- pLink rm key let pos' = fromMaybe pos mbpos return $! addAttributes attrs . link (rebasePath pos' target) title diff --git a/commonmark-pandoc/src/Commonmark/Pandoc.hs b/commonmark-pandoc/src/Commonmark/Pandoc.hs index 1679e56..6c4233d 100644 --- a/commonmark-pandoc/src/Commonmark/Pandoc.hs +++ b/commonmark-pandoc/src/Commonmark/Pandoc.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -32,6 +33,7 @@ import Commonmark.Extensions.Attributes import Commonmark.Extensions.Footnote import Commonmark.Extensions.TaskList import Commonmark.Extensions.Smart +import Commonmark.Extensions.Citations import Data.Char (isSpace) import Data.Coerce (coerce) @@ -178,6 +180,17 @@ instance HasSuperscript (Cm a B.Inlines) where instance HasSubscript (Cm a B.Inlines) where subscript ils = B.subscript <$> ils +instance HasCitations (Cm a B.Inlines) where + citationGroup ils = B.spanWith ("",["citation-group"],[]) <$> ils + citation ident suppressAuthor = + Cm $ B.spanWith ("", ["citation"], + ([("citation-identifier", ident)] ++ + [("suppress-author","true") | suppressAuthor])) mempty + hasCitations (Cm ils) = + let isCitation (Span (_,["citation"],_) _) = True + isCitation _ = False + in any isCitation ils + instance Rangeable (Cm a B.Inlines) => HasSpan (Cm a B.Inlines) where spanWith attrs ils = B.spanWith (addToPandocAttr attrs nullAttr) <$> ils diff --git a/commonmark/src/Commonmark/Html.hs b/commonmark/src/Commonmark/Html.hs index 11fc1ea..5539ab8 100644 --- a/commonmark/src/Commonmark/Html.hs +++ b/commonmark/src/Commonmark/Html.hs @@ -4,7 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module Commonmark.Html - ( Html + ( Html(..) + , ElementType(..) , htmlInline , htmlBlock , htmlText diff --git a/commonmark/src/Commonmark/Inlines.hs b/commonmark/src/Commonmark/Inlines.hs index 3e28429..5743239 100644 --- a/commonmark/src/Commonmark/Inlines.hs +++ b/commonmark/src/Commonmark/Inlines.hs @@ -17,6 +17,8 @@ module Commonmark.Inlines , BracketedSpec(..) , defaultBracketedSpecs , LinkInfo(..) + , Chunk(..) + , ChunkType(..) , imageSpec , linkSpec , pLink @@ -249,7 +251,7 @@ data BracketedSpec il = BracketedSpec , bracketedPrefix :: Maybe Char -- ^ Prefix character. , bracketedSuffixEnd :: Maybe Char -- ^ Suffix character. , bracketedSuffix :: ReferenceMap - -> Text + -> [Chunk il] -> Parsec [Tok] () (il -> il) -- ^ Parser for suffix after -- brackets. Returns a constructor. @@ -286,15 +288,17 @@ imageSpec = BracketedSpec } pLinkSuffix :: IsInline il - => ReferenceMap -> Text -> Parsec [Tok] s (il -> il) -pLinkSuffix rm key = do - LinkInfo target title attrs _mbpos <- pLink rm key + => ReferenceMap -> [Chunk il] -> Parsec [Tok] s (il -> il) +pLinkSuffix rm chunksInside = do + LinkInfo target title attrs _mbpos <- + pLink rm (untokenize $ concatMap chunkToks chunksInside) return $! addAttributes attrs . link target title pImageSuffix :: IsInline il - => ReferenceMap -> Text -> Parsec [Tok] s (il -> il) -pImageSuffix rm key = do - LinkInfo target title attrs _mbpos <- pLink rm key + => ReferenceMap -> [Chunk il] -> Parsec [Tok] s (il -> il) +pImageSuffix rm chunksInside = do + LinkInfo target title attrs _mbpos <- + pLink rm (untokenize $ concatMap chunkToks chunksInside) return $! addAttributes attrs . image target title --- @@ -734,15 +738,6 @@ processBs bracketedSpecs st = Just closer@(Chunk Delim{ delimType = ']'} closePos _)) -> let chunksinside = takeWhile (\ch -> chunkPos ch /= closePos) (afters left) - isBracket (Chunk Delim{ delimType = c' } _ _) = - c' == '[' || c' == ']' - isBracket _ = False - key = if any isBracket chunksinside - then "" - else - case untokenize (concatMap chunkToks chunksinside) of - ks | T.length ks <= 999 -> ks - _ -> "" prefixChar = case befores left of Chunk Delim{delimType = c} _ [_] : _ -> Just c @@ -764,7 +759,7 @@ processBs bracketedSpecs st = (withRaw (do setPosition suffixPos (spec, constructor) <- choice $ - map (\s -> (s,) <$> bracketedSuffix s rm key) + map (\s -> (s,) <$> bracketedSuffix s rm chunksinside) specs pos <- getPosition return (spec, constructor, pos)))