commonmark-extensions 0.2.4 → 0.2.5

raw patch · 7 files changed

+248/−8 lines, 7 filesdep ~commonmarkPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: commonmark

API changes (from Hackage documentation)

Files

• changelog.md +11/−0
• commonmark-extensions.cabal +5/−4
• src/Commonmark/Extensions.hs +4/−2
• src/Commonmark/Extensions/Alerts.hs +137/−0
• src/Commonmark/Extensions/Footnote.hs +6/−2
• test/footnotes.md +84/−0
• test/test-commonmark-extensions.hs +1/−0

@@ -1,5 +1,16 @@ # Changelog for commonmark-extensions +## 0.2.5++  * Add support for alerts extension, supporting GitHub-style alerts (#132).+    <https://docs.github.com/en/get-started/writing-on-github/getting-started-with-writing-and-formatting-on-github/basic-writing-and-formatting-syntax#alerts>+    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,

@@ -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

@@ -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 

@@ -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"

@@ -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,

@@ -134,3 +134,87 @@ </div> </section> ````````````````````````````````++Footnote labels cannot be empty, or composed only of whitespace.++```````````````````````````````` example+Test [^] link [^ ]++[^]: https://haskell.org+.+<p>Test <a href="https://haskell.org">^</a> link <a href="https://haskell.org">^ </a></p>+````````````````````````````````++```````````````````````````````` example+[^]: not a footnote++[^ ]: not a footnote++[^+]: not a footnote+.+<p>[^]: not a footnote</p>+<p>[^ ]: not a footnote</p>+<p>[^+]: not a footnote</p>+````````````````````````````````++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]+.+<p>[^foo<br />+bar]: not a footnote definition</p>+<p>[^third+fourth]: not a footnote definition</p>+<p><a href="https://haskell.org">baz<br />+quux</a>+[^foo<br />+bar]+<a href="https://haskell.org">first+second</a>+[^third+fourth]</p>+````````````````````````````````++Paragraphs in footnotes can be lazily wrapped (#126).++```````````````````````````````` example+[^foo]:bar+baz++[^foo]+.+<p><sup class="footnote-ref"><a href="#fn-foo" id="fnref-foo">1</a></sup></p>+<section class="footnotes">+<div class="footnote" id="fn-foo">+<div class="footnote-number">+<a href="#fnref-foo">1</a>+</div>+<div class="footnote-contents">+<p>bar+baz</p>+</div>+</div>+</section>+````````````````````````````````

@@ -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])