diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,16 @@ # Changelog for commonmark-extensions +## 0.2.5 + + * Add support for alerts extension, supporting GitHub-style alerts (#132). + + New module Commonmark.Extensions.Alerts [API change]. + + * Do not accept footnote labels with line breaks (Michael Howell). + + * Parse `[^ ]` and `[^]` as links (Michael Howell). This is consistent with + most other CommonMark parsers, even when they have support for footnotes turned on. + ## 0.2.4 * Make `pipe_tables` extension treat backslash escapes like GH does (#112, diff --git a/commonmark-extensions.cabal b/commonmark-extensions.cabal --- a/commonmark-extensions.cabal +++ b/commonmark-extensions.cabal @@ -1,5 +1,5 @@ name: commonmark-extensions -version: 0.2.4 +version: 0.2.5 synopsis: Pure Haskell commonmark parser. description: This library provides some useful extensions to core commonmark @@ -59,7 +59,7 @@ , transformers , filepath , network-uri - , commonmark >= 0.2.2 && < 0.3 + , commonmark >= 0.2.4.1 && < 0.3 -- for extensions: , emojis >= 0.1 && < 0.2 exposed-modules: @@ -82,6 +82,7 @@ Commonmark.Extensions.ImplicitHeadingReferences Commonmark.Extensions.RebaseRelativePaths Commonmark.Extensions.Wikilinks + Commonmark.Extensions.Alerts ghc-options: -Wall -fno-warn-unused-do-bind -funbox-small-strict-fields if impl(ghc >= 8.10) ghc-options: -Wunused-packages @@ -99,7 +100,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-K40K build-depends: base >= 4.9 && <5 - , commonmark >= 0.2 && < 0.3 + , commonmark >= 0.2.4.1 && < 0.3 , commonmark-extensions , text , tasty @@ -112,7 +113,7 @@ main-is: benchmark.hs hs-source-dirs: benchmark build-depends: - commonmark >= 0.2 && < 0.3 + commonmark >= 0.2.4.1 && < 0.3 , commonmark-extensions , base >= 4.9 && < 5 , text diff --git a/src/Commonmark/Extensions.hs b/src/Commonmark/Extensions.hs --- a/src/Commonmark/Extensions.hs +++ b/src/Commonmark/Extensions.hs @@ -39,6 +39,7 @@ , module Commonmark.Extensions.TaskList , module Commonmark.Extensions.ImplicitHeadingReferences , module Commonmark.Extensions.Wikilinks + , module Commonmark.Extensions.Alerts , module Commonmark.Extensions.RebaseRelativePaths , gfmExtensions ) where @@ -60,6 +61,7 @@ import Commonmark.Extensions.TaskList import Commonmark.Extensions.ImplicitHeadingReferences import Commonmark.Extensions.Wikilinks +import Commonmark.Extensions.Alerts import Commonmark.Extensions.RebaseRelativePaths import Commonmark import Data.Typeable @@ -68,9 +70,9 @@ gfmExtensions :: (Monad m, Typeable m, Typeable il, Typeable bl, IsBlock il bl, IsInline il, HasFootnote il bl, HasEmoji il, HasStrikethrough il, HasPipeTable il bl, - HasTaskList il bl, ToPlainText il) + HasTaskList il bl, ToPlainText il, HasAlerts il bl) => SyntaxSpec m il bl gfmExtensions = emojiSpec <> strikethroughSpec <> pipeTableSpec <> autolinkSpec <> - autoIdentifiersSpec <> taskListSpec <> footnoteSpec + autoIdentifiersSpec <> taskListSpec <> footnoteSpec <> alertSpec diff --git a/src/Commonmark/Extensions/Alerts.hs b/src/Commonmark/Extensions/Alerts.hs new file mode 100644 --- /dev/null +++ b/src/Commonmark/Extensions/Alerts.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Commonmark.Extensions.Alerts + ( alertSpec + , alertSvgText + , alertClass + , alertName + , AlertType(..) + , HasAlerts(..) + ) +where +import Commonmark.Types +import Commonmark.Syntax +import Commonmark.Blocks +import Commonmark.SourceMap +import Commonmark.TokParsers +import Commonmark.Tokens +import Commonmark.Html +import Control.Monad (void) +import Data.Dynamic +import Data.Tree +import Text.Parsec +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +alertSpec :: (Monad m, Typeable m, IsBlock il bl, IsInline il, + Typeable il, Typeable bl, HasAlerts il bl) + => SyntaxSpec m il bl +alertSpec = mempty + { syntaxBlockSpecs = [alertBlockSpec] + } + + +alertBlockSpec :: (Monad m, IsBlock il bl, HasAlerts il bl) + => BlockSpec m il bl +alertBlockSpec = BlockSpec + { blockType = "Alert" + , blockStart = do + nonindentSpaces + pos <- getPosition + _ <- symbol '>' + _ <- option 0 (gobbleSpaces 1) + _ <- symbol '[' + _ <- symbol '!' + let eqCI x y = x == T.toUpper y + alertType <- (NoteAlert <$ satisfyWord (eqCI "NOTE")) + <|> (TipAlert <$ satisfyWord (eqCI "TIP")) + <|> (ImportantAlert <$ satisfyWord (eqCI "IMPORTANT")) + <|> (WarningAlert <$ satisfyWord (eqCI "WARNING")) + <|> (CautionAlert <$ satisfyWord (eqCI "CAUTION")) + _ <- symbol ']' + skipWhile (hasType Spaces) + lookAhead $ void lineEnd <|> eof + addNodeToStack $ + Node (defBlockData alertBlockSpec){ + blockData = toDyn alertType, + blockStartPos = [pos] } [] + return BlockStartMatch + , blockCanContain = const True + , blockContainsLines = False + , blockParagraph = False + , blockContinue = \n -> try $ do + nonindentSpaces + pos <- getPosition + _ <- symbol '>' + _ <- gobbleUpToSpaces 1 + return (pos, n) + , blockConstructor = \node -> do + let alertType = fromDyn (blockData (rootLabel node)) NoteAlert + alert alertType . mconcat <$> renderChildren node + , blockFinalize = defaultFinalizer + } + +data AlertType = + NoteAlert + | TipAlert + | ImportantAlert + | WarningAlert + | CautionAlert + deriving (Show, Typeable, Eq, Ord) + +alertClass :: AlertType -> Text +alertClass NoteAlert = "alert-note" +alertClass TipAlert = "alert-tip" +alertClass ImportantAlert = "alert-important" +alertClass WarningAlert = "alert-warning" +alertClass CautionAlert = "alert-caution" + +alertName :: AlertType -> Text +alertName NoteAlert = "Note" +alertName TipAlert = "Tip" +alertName ImportantAlert = "Important" +alertName WarningAlert = "Warning" +alertName CautionAlert = "Caution" + +alertSvg :: AlertType -> Html a +alertSvg alertType = + addAttribute ("viewBox", "0 0 16 16") $ + addAttribute ("width", "16") $ + addAttribute ("height", "16") $ + addAttribute ("aria-hidden", "true") $ + htmlBlock "svg" $ + Just $ htmlRaw "\n" <> + addAttribute ("d", svgPath alertType) + (htmlBlock "path" (Just mempty)) + +alertSvgText :: AlertType -> Text +alertSvgText = TL.toStrict . renderHtml . alertSvg + +svgPath :: AlertType -> Text +svgPath NoteAlert = "M0 8a8 8 0 1 1 16 0A8 8 0 0 1 0 8Zm8-6.5a6.5 6.5 0 1 0 0 13 6.5 6.5 0 0 0 0-13ZM6.5 7.75A.75.75 0 0 1 7.25 7h1a.75.75 0 0 1 .75.75v2.75h.25a.75.75 0 0 1 0 1.5h-2a.75.75 0 0 1 0-1.5h.25v-2h-.25a.75.75 0 0 1-.75-.75ZM8 6a1 1 0 1 1 0-2 1 1 0 0 1 0 2Z" +svgPath TipAlert = "M8 1.5c-2.363 0-4 1.69-4 3.75 0 .984.424 1.625.984 2.304l.214.253c.223.264.47.556.673.848.284.411.537.896.621 1.49a.75.75 0 0 1-1.484.211c-.04-.282-.163-.547-.37-.847a8.456 8.456 0 0 0-.542-.68c-.084-.1-.173-.205-.268-.32C3.201 7.75 2.5 6.766 2.5 5.25 2.5 2.31 4.863 0 8 0s5.5 2.31 5.5 5.25c0 1.516-.701 2.5-1.328 3.259-.095.115-.184.22-.268.319-.207.245-.383.453-.541.681-.208.3-.33.565-.37.847a.751.751 0 0 1-1.485-.212c.084-.593.337-1.078.621-1.489.203-.292.45-.584.673-.848.075-.088.147-.173.213-.253.561-.679.985-1.32.985-2.304 0-2.06-1.637-3.75-4-3.75ZM5.75 12h4.5a.75.75 0 0 1 0 1.5h-4.5a.75.75 0 0 1 0-1.5ZM6 15.25a.75.75 0 0 1 .75-.75h2.5a.75.75 0 0 1 0 1.5h-2.5a.75.75 0 0 1-.75-.75Z" +svgPath ImportantAlert = "M0 1.75C0 .784.784 0 1.75 0h12.5C15.216 0 16 .784 16 1.75v9.5A1.75 1.75 0 0 1 14.25 13H8.06l-2.573 2.573A1.458 1.458 0 0 1 3 14.543V13H1.75A1.75 1.75 0 0 1 0 11.25Zm1.75-.25a.25.25 0 0 0-.25.25v9.5c0 .138.112.25.25.25h2a.75.75 0 0 1 .75.75v2.19l2.72-2.72a.749.749 0 0 1 .53-.22h6.5a.25.25 0 0 0 .25-.25v-9.5a.25.25 0 0 0-.25-.25Zm7 2.25v2.5a.75.75 0 0 1-1.5 0v-2.5a.75.75 0 0 1 1.5 0ZM9 9a1 1 0 1 1-2 0 1 1 0 0 1 2 0Z" +svgPath WarningAlert = "M6.457 1.047c.659-1.234 2.427-1.234 3.086 0l6.082 11.378A1.75 1.75 0 0 1 14.082 15H1.918a1.75 1.75 0 0 1-1.543-2.575Zm1.763.707a.25.25 0 0 0-.44 0L1.698 13.132a.25.25 0 0 0 .22.368h12.164a.25.25 0 0 0 .22-.368Zm.53 3.996v2.5a.75.75 0 0 1-1.5 0v-2.5a.75.75 0 0 1 1.5 0ZM9 11a1 1 0 1 1-2 0 1 1 0 0 1 2 0Z" +svgPath CautionAlert = "M4.47.22A.749.749 0 0 1 5 0h6c.199 0 .389.079.53.22l4.25 4.25c.141.14.22.331.22.53v6a.749.749 0 0 1-.22.53l-4.25 4.25A.749.749 0 0 1 11 16H5a.749.749 0 0 1-.53-.22L.22 11.53A.749.749 0 0 1 0 11V5c0-.199.079-.389.22-.53Zm.84 1.28L1.5 5.31v5.38l3.81 3.81h5.38l3.81-3.81V5.31L10.69 1.5ZM8 4a.75.75 0 0 1 .75.75v3.5a.75.75 0 0 1-1.5 0v-3.5A.75.75 0 0 1 8 4Zm0 8a1 1 0 1 1 0-2 1 1 0 0 1 0 2Z" + +class IsBlock il bl => HasAlerts il bl | il -> bl where + alert :: AlertType -> bl -> bl + +instance Rangeable (Html a) => + HasAlerts (Html a) (Html a) where + alert alertType bs = + addAttribute ("class", "alert " <> alertClass alertType) $ + htmlBlock "div" (Just $ htmlRaw "\n" <> + addAttribute ("class", "alert-title") + (htmlBlock "p" (Just $ htmlRaw "\n" <> + alertSvg alertType <> + htmlText (alertName alertType))) <> bs) + +instance (HasAlerts il bl, Semigroup bl, Semigroup il) + => HasAlerts (WithSourceMap il) (WithSourceMap bl) where + alert alertType bs = alert alertType <$> bs <* addName "alert" diff --git a/src/Commonmark/Extensions/Footnote.hs b/src/Commonmark/Extensions/Footnote.hs --- a/src/Commonmark/Extensions/Footnote.hs +++ b/src/Commonmark/Extensions/Footnote.hs @@ -101,9 +101,13 @@ pFootnoteLabel :: Monad m => ParsecT [Tok] u m Text pFootnoteLabel = try $ do - lab <- pLinkLabel + lab <- untokenize + <$> try (between (symbol '[') (symbol ']') + (snd <$> withRaw (many + (pEscaped <|> noneOfToks [Symbol ']', Symbol '[', LineEnd])))) case T.uncons lab of - Just ('^', t') -> return $! t' + Just ('^', t') | T.any (\x -> x /= ' ' && x /= '\t') t' && T.all (\x -> x /= '\n' && x /= '\r') t' + -> return $! t' _ -> mzero pFootnoteRef :: (Monad m, Typeable m, Typeable a, diff --git a/test/footnotes.md b/test/footnotes.md --- a/test/footnotes.md +++ b/test/footnotes.md @@ -134,3 +134,87 @@ ```````````````````````````````` + +Footnote labels cannot be empty, or composed only of whitespace. + +```````````````````````````````` example +Test [^] link [^ ] + +[^]: https://haskell.org +. +

Test ^ link ^

+```````````````````````````````` + +```````````````````````````````` example +[^]: not a footnote + +[^ ]: not a footnote + +[^ +]: not a footnote +. +

[^]: not a footnote

+

[^ ]: not a footnote

+

[^ +]: not a footnote

+```````````````````````````````` + +Footnote labels cannot contain line breaks, even where link labels can. + +```````````````````````````````` example +[^foo\ +bar]: not a footnote definition + +[baz\ +quux]: https://haskell.org + +[first +second]: https://haskell.org + +[^third +fourth]: not a footnote definition + +[baz\ +quux] +[^foo\ +bar] +[first +second] +[^third +fourth] +. +

[^foo
+bar]: not a footnote definition

+

[^third +fourth]: not a footnote definition

+

baz
+quux +[^foo
+bar] +first +second +[^third +fourth]

+```````````````````````````````` + +Paragraphs in footnotes can be lazily wrapped (#126). + +```````````````````````````````` example +[^foo]:bar +baz + +[^foo] +. +

1

+
+
+
+1 +
+
+

bar +baz

+
+
+
+```````````````````````````````` diff --git a/test/test-commonmark-extensions.hs b/test/test-commonmark-extensions.hs --- a/test/test-commonmark-extensions.hs +++ b/test/test-commonmark-extensions.hs @@ -49,6 +49,7 @@ autoIdentifiersSpec <> attributesSpec <> implicitHeadingReferencesSpec) , ("test/wikilinks_title_before_pipe.md", wikilinksSpec TitleBeforePipe) , ("test/wikilinks_title_after_pipe.md", wikilinksSpec TitleAfterPipe) + , ("test/alerts.md", alertSpec) ] defaultMain $ testGroup "Tests" (tests ++ [rebaseRelativePathTests])