{-# 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 = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxBlockSpecs = [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
             ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m ()
nonindentSpaces
             pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
             _ <- symbol '>'
             _ <- option 0 (gobbleSpaces 1)
             _ <- symbol '['
             _ <- symbol '!'
             let eqCI Text
x Text
y = Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
T.toUpper Text
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 :: BlockSpec m il bl -> Bool
blockCanContain     = Bool -> BlockSpec m il bl -> Bool
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 -> BlockParser m il bl (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (BlockParser m il bl (SourcePos, BlockNode m il bl)
 -> BlockParser m il bl (SourcePos, BlockNode m il bl))
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall a b. (a -> b) -> a -> b
$ do
             ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m ()
nonindentSpaces
             pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
             _ <- symbol '>'
             _ <- gobbleUpToSpaces 1
             return (pos, n)
     , blockConstructor :: BlockNode m il bl -> BlockParser m il bl bl
blockConstructor    = \BlockNode m il bl
node -> do
         let alertType :: AlertType
alertType = Dynamic -> AlertType -> AlertType
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
node)) AlertType
NoteAlert
         AlertType -> bl -> bl
forall il bl. HasAlerts il bl => AlertType -> bl -> bl
alert AlertType
alertType (bl -> bl) -> ([bl] -> bl) -> [bl] -> bl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [bl] -> bl
forall a. Monoid a => [a] -> a
mconcat ([bl] -> bl)
-> ParsecT [Tok] (BPState m il bl) m [bl] -> BlockParser m il bl bl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m [bl]
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       = BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
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
(Int -> AlertType -> ShowS)
-> (AlertType -> String)
-> ([AlertType] -> ShowS)
-> Show AlertType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AlertType -> ShowS
showsPrec :: Int -> AlertType -> ShowS
$cshow :: AlertType -> String
show :: AlertType -> String
$cshowList :: [AlertType] -> ShowS
showList :: [AlertType] -> ShowS
Show, Typeable, AlertType -> AlertType -> Bool
(AlertType -> AlertType -> Bool)
-> (AlertType -> AlertType -> Bool) -> Eq AlertType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AlertType -> AlertType -> Bool
== :: AlertType -> AlertType -> Bool
$c/= :: AlertType -> AlertType -> Bool
/= :: AlertType -> AlertType -> Bool
Eq, Eq AlertType
Eq AlertType =>
(AlertType -> AlertType -> Ordering)
-> (AlertType -> AlertType -> Bool)
-> (AlertType -> AlertType -> Bool)
-> (AlertType -> AlertType -> Bool)
-> (AlertType -> AlertType -> Bool)
-> (AlertType -> AlertType -> AlertType)
-> (AlertType -> AlertType -> AlertType)
-> Ord 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
$ccompare :: AlertType -> AlertType -> Ordering
compare :: AlertType -> AlertType -> Ordering
$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
>= :: AlertType -> AlertType -> Bool
$cmax :: AlertType -> AlertType -> AlertType
max :: AlertType -> AlertType -> AlertType
$cmin :: AlertType -> AlertType -> AlertType
min :: AlertType -> AlertType -> AlertType
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 =
  Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"viewBox", Text
"0 0 16 16") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
  Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"width", Text
"16") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
  Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"height", Text
"16") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
  Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"aria-hidden", Text
"true") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
  Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"svg" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$
    Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\n" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<>
      Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"d", AlertType -> Text
svgPath AlertType
alertType)
        (Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"path" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just Html a
forall a. Monoid a => a
mempty))

alertSvgText :: AlertType -> Text
alertSvgText :: AlertType -> Text
alertSvgText = LazyText -> Text
TL.toStrict (LazyText -> Text) -> (AlertType -> LazyText) -> AlertType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html Any -> LazyText
forall a. Html a -> LazyText
renderHtml (Html Any -> LazyText)
-> (AlertType -> Html Any) -> AlertType -> LazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlertType -> Html Any
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 =
    Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"alert " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AlertType -> Text
alertClass AlertType
alertType) (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
    Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"div" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\n" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<>
      Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"alert-title")
        (Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"p" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\n" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<>
           AlertType -> Html a
forall a. AlertType -> Html a
alertSvg AlertType
alertType Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<>
           Text -> Html a
forall a. Text -> Html a
htmlText (AlertType -> Text
alertName AlertType
alertType))) Html a -> Html a -> Html a
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 = AlertType -> bl -> bl
forall il bl. HasAlerts il bl => AlertType -> bl -> bl
alert AlertType
alertType (bl -> bl) -> WithSourceMap bl -> WithSourceMap bl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap bl
bs WithSourceMap bl -> WithSourceMap () -> WithSourceMap bl
forall a b. WithSourceMap a -> WithSourceMap b -> WithSourceMap a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"alert"