{-# 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 :: forall (m :: * -> *) il bl. (Monad m, Typeable m, IsBlock il bl, IsInline il, Typeable il, Typeable bl, HasAlerts il bl) => SyntaxSpec m il bl alertSpec = forall a. Monoid a => a mempty { syntaxBlockSpecs :: [BlockSpec m il bl] syntaxBlockSpecs = [forall (m :: * -> *) il bl. (Monad m, IsBlock il bl, HasAlerts il bl) => BlockSpec m il bl alertBlockSpec] } alertBlockSpec :: (Monad m, IsBlock il bl, HasAlerts il bl) => BlockSpec m il bl alertBlockSpec :: forall (m :: * -> *) il bl. (Monad m, IsBlock il bl, HasAlerts il bl) => BlockSpec m il bl alertBlockSpec = BlockSpec { blockType :: Text blockType = Text "Alert" , blockStart :: BlockParser m il bl BlockStartResult blockStart = do forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m () nonindentSpaces SourcePos pos <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos getPosition Tok _ <- forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok symbol Char '>' Int _ <- forall s (m :: * -> *) t a u. Stream s m t => a -> ParsecT s u m a -> ParsecT s u m a option Int 0 (forall (m :: * -> *) u. Monad m => Int -> ParsecT [Tok] u m Int gobbleSpaces Int 1) Tok _ <- forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok symbol Char '[' Tok _ <- forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok symbol Char '!' let eqCI :: Text -> Text -> Bool eqCI Text x Text y = Text x forall a. Eq a => a -> a -> Bool == Text -> Text T.toUpper Text y AlertType alertType <- (AlertType NoteAlert forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ forall (m :: * -> *) s. Monad m => (Text -> Bool) -> ParsecT [Tok] s m Tok satisfyWord (Text -> Text -> Bool eqCI Text "NOTE")) forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a <|> (AlertType TipAlert forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ forall (m :: * -> *) s. Monad m => (Text -> Bool) -> ParsecT [Tok] s m Tok satisfyWord (Text -> Text -> Bool eqCI Text "TIP")) forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a <|> (AlertType ImportantAlert forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ forall (m :: * -> *) s. Monad m => (Text -> Bool) -> ParsecT [Tok] s m Tok satisfyWord (Text -> Text -> Bool eqCI Text "IMPORTANT")) forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a <|> (AlertType WarningAlert forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ forall (m :: * -> *) s. Monad m => (Text -> Bool) -> ParsecT [Tok] s m Tok satisfyWord (Text -> Text -> Bool eqCI Text "WARNING")) forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a <|> (AlertType CautionAlert forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ forall (m :: * -> *) s. Monad m => (Text -> Bool) -> ParsecT [Tok] s m Tok satisfyWord (Text -> Text -> Bool eqCI Text "CAUTION")) Tok _ <- forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok symbol Char ']' forall (m :: * -> *) u. Monad m => (Tok -> Bool) -> ParsecT [Tok] u m () skipWhile (TokType -> Tok -> Bool hasType TokType Spaces) forall s (m :: * -> *) t u a. Stream s m t => ParsecT s u m a -> ParsecT s u m a lookAhead forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Functor f => f a -> f () void forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok lineEnd forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a <|> forall s (m :: * -> *) t u. (Stream s m t, Show t) => ParsecT s u m () eof forall (m :: * -> *) bl il. Monad m => BlockNode m bl il -> BlockParser m bl il () addNodeToStack forall a b. (a -> b) -> a -> b $ forall a. a -> [Tree a] -> Tree a Node (forall (m :: * -> *) il bl. BlockSpec m il bl -> BlockData m il bl defBlockData forall (m :: * -> *) il bl. (Monad m, IsBlock il bl, HasAlerts il bl) => BlockSpec m il bl alertBlockSpec){ blockData :: Dynamic blockData = forall a. Typeable a => a -> Dynamic toDyn AlertType alertType, blockStartPos :: [SourcePos] blockStartPos = [SourcePos pos] } [] forall (m :: * -> *) a. Monad m => a -> m a return BlockStartResult BlockStartMatch , blockCanContain :: BlockSpec m il bl -> Bool blockCanContain = forall a b. a -> b -> a const Bool True , blockContainsLines :: Bool blockContainsLines = Bool False , blockParagraph :: Bool blockParagraph = Bool False , blockContinue :: BlockNode m il bl -> BlockParser m il bl (SourcePos, BlockNode m il bl) blockContinue = \BlockNode m il bl n -> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a try forall a b. (a -> b) -> a -> b $ do forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m () nonindentSpaces SourcePos pos <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos getPosition Tok _ <- forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok symbol Char '>' Int _ <- forall (m :: * -> *) u. Monad m => Int -> ParsecT [Tok] u m Int gobbleUpToSpaces Int 1 forall (m :: * -> *) a. Monad m => a -> m a return (SourcePos pos, BlockNode m il bl n) , blockConstructor :: BlockNode m il bl -> BlockParser m il bl bl blockConstructor = \BlockNode m il bl node -> do let alertType :: AlertType alertType = forall a. Typeable a => Dynamic -> a -> a fromDyn (forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic blockData (forall a. Tree a -> a rootLabel BlockNode m il bl node)) AlertType NoteAlert forall il bl. HasAlerts il bl => AlertType -> bl -> bl alert AlertType alertType forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Monoid a => [a] -> a mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) il bl. (Monad m, IsBlock il bl) => BlockNode m il bl -> BlockParser m il bl [bl] renderChildren BlockNode m il bl node , blockFinalize :: BlockNode m il bl -> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl) blockFinalize = forall (m :: * -> *) il bl. Monad m => BlockNode m il bl -> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl) defaultFinalizer } data AlertType = NoteAlert | TipAlert | ImportantAlert | WarningAlert | CautionAlert deriving (Int -> AlertType -> ShowS [AlertType] -> ShowS AlertType -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [AlertType] -> ShowS $cshowList :: [AlertType] -> ShowS show :: AlertType -> String $cshow :: AlertType -> String showsPrec :: Int -> AlertType -> ShowS $cshowsPrec :: Int -> AlertType -> ShowS Show, Typeable, AlertType -> AlertType -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: AlertType -> AlertType -> Bool $c/= :: AlertType -> AlertType -> Bool == :: AlertType -> AlertType -> Bool $c== :: AlertType -> AlertType -> Bool Eq, Eq AlertType AlertType -> AlertType -> Bool AlertType -> AlertType -> Ordering AlertType -> AlertType -> AlertType forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: AlertType -> AlertType -> AlertType $cmin :: AlertType -> AlertType -> AlertType max :: AlertType -> AlertType -> AlertType $cmax :: AlertType -> AlertType -> AlertType >= :: AlertType -> AlertType -> Bool $c>= :: AlertType -> AlertType -> Bool > :: AlertType -> AlertType -> Bool $c> :: AlertType -> AlertType -> Bool <= :: AlertType -> AlertType -> Bool $c<= :: AlertType -> AlertType -> Bool < :: AlertType -> AlertType -> Bool $c< :: AlertType -> AlertType -> Bool compare :: AlertType -> AlertType -> Ordering $ccompare :: AlertType -> AlertType -> Ordering Ord) alertClass :: AlertType -> Text alertClass :: AlertType -> Text alertClass AlertType NoteAlert = Text "alert-note" alertClass AlertType TipAlert = Text "alert-tip" alertClass AlertType ImportantAlert = Text "alert-important" alertClass AlertType WarningAlert = Text "alert-warning" alertClass AlertType CautionAlert = Text "alert-caution" alertName :: AlertType -> Text alertName :: AlertType -> Text alertName AlertType NoteAlert = Text "Note" alertName AlertType TipAlert = Text "Tip" alertName AlertType ImportantAlert = Text "Important" alertName AlertType WarningAlert = Text "Warning" alertName AlertType CautionAlert = Text "Caution" alertSvg :: AlertType -> Html a alertSvg :: forall a. AlertType -> Html a alertSvg AlertType alertType = forall a. Attribute -> Html a -> Html a addAttribute (Text "viewBox", Text "0 0 16 16") forall a b. (a -> b) -> a -> b $ forall a. Attribute -> Html a -> Html a addAttribute (Text "width", Text "16") forall a b. (a -> b) -> a -> b $ forall a. Attribute -> Html a -> Html a addAttribute (Text "height", Text "16") forall a b. (a -> b) -> a -> b $ forall a. Attribute -> Html a -> Html a addAttribute (Text "aria-hidden", Text "true") forall a b. (a -> b) -> a -> b $ forall a. Text -> Maybe (Html a) -> Html a htmlBlock Text "svg" forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ forall a. Text -> Html a htmlRaw Text "\n" forall a. Semigroup a => a -> a -> a <> forall a. Attribute -> Html a -> Html a addAttribute (Text "d", AlertType -> Text svgPath AlertType alertType) (forall a. Text -> Maybe (Html a) -> Html a htmlBlock Text "path" (forall a. a -> Maybe a Just forall a. Monoid a => a mempty)) alertSvgText :: AlertType -> Text alertSvgText :: AlertType -> Text alertSvgText = Text -> Text TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Html a -> Text renderHtml forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. AlertType -> Html a alertSvg svgPath :: AlertType -> Text svgPath :: AlertType -> Text svgPath AlertType NoteAlert = Text "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 AlertType TipAlert = Text "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 AlertType ImportantAlert = Text "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 AlertType WarningAlert = Text "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 AlertType CautionAlert = Text "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 -> Html a -> Html a alert AlertType alertType Html a bs = forall a. Attribute -> Html a -> Html a addAttribute (Text "class", Text "alert " forall a. Semigroup a => a -> a -> a <> AlertType -> Text alertClass AlertType alertType) forall a b. (a -> b) -> a -> b $ forall a. Text -> Maybe (Html a) -> Html a htmlBlock Text "div" (forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ forall a. Text -> Html a htmlRaw Text "\n" forall a. Semigroup a => a -> a -> a <> forall a. Attribute -> Html a -> Html a addAttribute (Text "class", Text "alert-title") (forall a. Text -> Maybe (Html a) -> Html a htmlBlock Text "p" (forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ forall a. Text -> Html a htmlRaw Text "\n" forall a. Semigroup a => a -> a -> a <> forall a. AlertType -> Html a alertSvg AlertType alertType forall a. Semigroup a => a -> a -> a <> forall a. Text -> Html a htmlText (AlertType -> Text alertName AlertType alertType))) forall a. Semigroup a => a -> a -> a <> Html a bs) instance (HasAlerts il bl, Semigroup bl, Semigroup il) => HasAlerts (WithSourceMap il) (WithSourceMap bl) where alert :: AlertType -> WithSourceMap bl -> WithSourceMap bl alert AlertType alertType WithSourceMap bl bs = forall il bl. HasAlerts il bl => AlertType -> bl -> bl alert AlertType alertType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> WithSourceMap bl bs forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* Text -> WithSourceMap () addName Text "alert"