commonmark-extensions-0.2.5: src/Commonmark/Extensions/Alerts.hs
{-# 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"