{-# 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"