Skip to content

Commit

Permalink
Add support for alerts extension.
Browse files Browse the repository at this point in the history 
* The `alerts` extension supports GitHub-style alerts.
  https://github.com/orgs/community/discussions/16925

* New module Commonmark.Extensions.Alerts

* This is supported in both the default HTML renderer
  and commonmark-pandoc.
  • Loading branch information
@jgm
jgm committed Dec 5, 2023
1 parent dc94f6c commit 9da8200
Show file tree
Hide file tree
Showing 9 changed files with 281 additions and 2 deletions.
4 changes: 4 additions & 0 deletions commonmark-cli/src/convert.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -137,6 +137,7 @@ extensions :: (Monad m, Typeable m,
HasDefinitionList il bl,
HasDiv bl,
HasTaskList il bl,
HasAlerts il bl,
HasFootnote il bl)
=> [(String, SyntaxSpec m il bl)]
extensions =
Expand All @@ -163,6 +164,7 @@ extensions =
,("wikilinks_title_before_pipe", wikilinksSpec TitleBeforePipe)
,("wikilinks_title_after_pipe", wikilinksSpec TitleAfterPipe)
,("rebase_relative_paths", rebaseRelativePathsSpec)
,("alerts", alertSpec)
,("gfm", gfmExtensions)
]

Expand All @@ -186,7 +188,9 @@ specFromExtensionNames ::
HasSubscript il,
HasDefinitionList il bl,
HasDiv bl,
HasAlerts il bl,
HasTaskList il bl,
HasAlerts il bl,
HasFootnote il bl)
=> [String] -> IO (SyntaxSpec m il bl)
specFromExtensionNames extnames = do
Expand Down
1 change: 1 addition & 0 deletions commonmark-extensions/commonmark-extensions.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -82,6 +82,7 @@ library
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
Expand Down
6 changes: 4 additions & 2 deletions commonmark-extensions/src/Commonmark/Extensions.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -39,6 +39,7 @@ module Commonmark.Extensions
, module Commonmark.Extensions.TaskList
, module Commonmark.Extensions.ImplicitHeadingReferences
, module Commonmark.Extensions.Wikilinks
, module Commonmark.Extensions.Alerts
, module Commonmark.Extensions.RebaseRelativePaths
, gfmExtensions
) where
Expand All @@ -60,6 +61,7 @@ import Commonmark.Extensions.FancyList
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
Expand All @@ -68,9 +70,9 @@ import Data.Typeable
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

135 changes: 135 additions & 0 deletions commonmark-extensions/src/Commonmark/Extensions/Alerts.hs
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,135 @@
{-# 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.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 '!'
alertType <- (NoteAlert <$ satisfyWord (== "NOTE"))
<|> (TipAlert <$ satisfyWord (== "TIP"))
<|> (ImportantAlert <$ satisfyWord (== "IMPORTANT"))
<|> (WarningAlert <$ satisfyWord (== "WARNING"))
<|> (CautionAlert <$ satisfyWord (== "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"
111 changes: 111 additions & 0 deletions commonmark-extensions/test/alerts.md
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,111 @@
## Alerts

GitHub style alerts look like this:

```````````````````````````````` example
> [!NOTE]
> Highlights information that users should take into account, even when skimming.
.
<div class="alert alert-note">
<p class="alert-title">
<svg viewBox="0 0 16 16" width="16" height="16" aria-hidden="true">
<path d="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"></path>
</svg>
Note</p>
<p>Highlights information that users should take into account, even when skimming.</p>
</div>
````````````````````````````````

It shouldn't matter if there's a soft break or hard break after
the `[!NOTE]`:

```````````````````````````````` example
> [!NOTE]
> Highlights information that users should take into account, even when skimming.
.
<div class="alert alert-note">
<p class="alert-title">
<svg viewBox="0 0 16 16" width="16" height="16" aria-hidden="true">
<path d="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"></path>
</svg>
Note</p>
<p>Highlights information that users should take into account, even when skimming.</p>
</div>
````````````````````````````````

Alerts can contain multiple blocks:

```````````````````````````````` example
> [!NOTE]
> Highlights information that users should take into account, even when skimming.
>
> Paragraph two.
.
<div class="alert alert-note">
<p class="alert-title">
<svg viewBox="0 0 16 16" width="16" height="16" aria-hidden="true">
<path d="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"></path>
</svg>
Note</p>
<p>Highlights information that users should take into account, even when skimming.</p>
<p>Paragraph two.</p>
</div>
````````````````````````````````

Other kinds of alerts:

```````````````````````````````` example
> [!TIP]
> Optional information to help a user be more successful.
.
<div class="alert alert-tip">
<p class="alert-title">
<svg viewBox="0 0 16 16" width="16" height="16" aria-hidden="true">
<path d="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"></path>
</svg>
Tip</p>
<p>Optional information to help a user be more successful.</p>
</div>
````````````````````````````````

```````````````````````````````` example
> [!IMPORTANT]
> Crucial information necessary for users to succeed.
.
<div class="alert alert-important">
<p class="alert-title">
<svg viewBox="0 0 16 16" width="16" height="16" aria-hidden="true">
<path d="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"></path>
</svg>
Important</p>
<p>Crucial information necessary for users to succeed.</p>
</div>
````````````````````````````````

```````````````````````````````` example
> [!WARNING]
> Critical content demanding immediate user attention due to potential risks.
.
<div class="alert alert-warning">
<p class="alert-title">
<svg viewBox="0 0 16 16" width="16" height="16" aria-hidden="true">
<path d="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"></path>
</svg>
Warning</p>
<p>Critical content demanding immediate user attention due to potential risks.</p>
</div>
````````````````````````````````

```````````````````````````````` example
> [!CAUTION]
> Negative potential consequences of an action.
.
<div class="alert alert-caution">
<p class="alert-title">
<svg viewBox="0 0 16 16" width="16" height="16" aria-hidden="true">
<path d="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"></path>
</svg>
Caution</p>
<p>Negative potential consequences of an action.</p>
</div>
````````````````````````````````
1 change: 1 addition & 0 deletions commonmark-extensions/test/test-commonmark-extensions.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,7 @@ main = do
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])

Expand Down
1 change: 1 addition & 0 deletions commonmark-pandoc/commonmark-pandoc.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,7 @@ library
, commonmark >= 0.2 && < 0.3
, commonmark-extensions >= 0.2.1 && < 0.3
, pandoc-types >= 1.21 && < 1.24
, network-uri
, text
if impl(ghc >= 8.10)
ghc-options: -Wunused-packages
Expand Down
21 changes: 21 additions & 0 deletions commonmark-pandoc/src/Commonmark/Pandoc.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@ where
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Read as TR
import Network.URI (escapeURIString, isUnescapedInURI)
import Text.Pandoc.Definition
import Text.Pandoc.Walk
import qualified Text.Pandoc.Builder as B
Expand All @@ -31,6 +32,7 @@ import Commonmark.Extensions.DefinitionList
import Commonmark.Extensions.Attributes
import Commonmark.Extensions.Footnote
import Commonmark.Extensions.TaskList
import Commonmark.Extensions.Alerts
import Commonmark.Extensions.Smart
import Data.Char (isSpace)
import Data.Coerce (coerce)
Expand Down Expand Up @@ -144,6 +146,25 @@ instance (Rangeable (Cm a B.Inlines), Rangeable (Cm a B.Blocks))
definitionList _ items =
Cm $ B.definitionList $ map coerce items

instance (Rangeable (Cm a B.Inlines), Rangeable (Cm a B.Blocks))
=> HasAlerts (Cm a B.Inlines) (Cm a B.Blocks) where
alert alertType bs =
Cm $ B.divWith ("",["alert", "alert-" <> alertClass alertType],[])
$ B.divWith ("",["alert-title"],[])
(B.para (B.image ("data:image/svg+xml;utf8," <>
(T.pack . escapeURIString isUnescapedInURI . T.unpack $
insertXmlns $
T.filter (/='\n') $ alertSvgText alertType))
"" (B.text $ alertName alertType <> " icon")
<> B.space <> B.str (alertName alertType)))
<> coerce bs

insertXmlns :: T.Text -> T.Text
insertXmlns t =
case T.stripPrefix "<svg " t of
Just rest -> "<svg xmlns=\"http://www.w3.org/2000/svg\" " <> rest
Nothing -> t

instance (Rangeable (Cm a B.Inlines), Rangeable (Cm a B.Blocks))
=> HasTaskList (Cm a B.Inlines) (Cm a B.Blocks) where
taskList _ spacing items =
Expand Down
3 changes: 3 additions & 0 deletions commonmark/src/Commonmark/Html.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -207,6 +207,7 @@ html5Attributes = Set.fromList
, "allowpaymentrequest"
, "allowusermedia"
, "alt"
, "aria-hidden"
, "as"
, "async"
, "autocapitalize"
Expand All @@ -225,6 +226,7 @@ html5Attributes = Set.fromList
, "controls"
, "coords"
, "crossorigin"
, "d"
, "data"
, "datetime"
, "decoding"
Expand Down Expand Up @@ -405,6 +407,7 @@ html5Attributes = Set.fromList
, "updateviacache"
, "usemap"
, "value"
, "viewBox"
, "width"
, "workertype"
, "wrap"
Expand Down

0 comments on commit 9da8200

Please sign in to comment.