{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
module Text.Markdown
    ( -- * Functions
      markdown
      -- * Settings
    , MarkdownSettings
    , defaultMarkdownSettings
    , msXssProtect
    , msStandaloneHtml
    , msFencedHandlers
    , msBlockCodeRenderer
    , msLinkNewTab
    , msBlankBeforeBlockquote
    , msBlockFilter
    , msAddHeadingId
    , setNoFollowExternal
      -- * Newtype
    , Markdown (..)
      -- * Fenced handlers
    , FencedHandler (..)
    , codeFencedHandler
    , htmlFencedHandler
      -- * Convenience re-exports
    , def
    ) where

import Control.Arrow ((&&&))
import Text.Markdown.Inline
import Text.Markdown.Block
import Text.Markdown.Types
import Prelude hiding (sequence, takeWhile)
import Data.Char (isAlphaNum)
import Data.Default (Default (..))
import Data.List (intercalate, isInfixOf)
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Text.Blaze (toValue)
import Text.Blaze.Html (ToMarkup (..), Html)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Monoid (Monoid (mappend, mempty, mconcat), (<>))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import Text.HTML.SanitizeXSS (sanitizeBalance)
import qualified Data.Map as Map
import Data.String (IsString)
import Data.Semigroup (Semigroup)

-- | A newtype wrapper providing a @ToHtml@ instance.
newtype Markdown = Markdown TL.Text
  deriving(Markdown -> Markdown -> Bool
(Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Bool) -> Eq Markdown
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Markdown -> Markdown -> Bool
$c/= :: Markdown -> Markdown -> Bool
== :: Markdown -> Markdown -> Bool
$c== :: Markdown -> Markdown -> Bool
Eq, Eq Markdown
Eq Markdown =>
(Markdown -> Markdown -> Ordering)
-> (Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Markdown)
-> (Markdown -> Markdown -> Markdown)
-> Ord Markdown
Markdown -> Markdown -> Bool
Markdown -> Markdown -> Ordering
Markdown -> Markdown -> Markdown
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 :: Markdown -> Markdown -> Markdown
$cmin :: Markdown -> Markdown -> Markdown
max :: Markdown -> Markdown -> Markdown
$cmax :: Markdown -> Markdown -> Markdown
>= :: Markdown -> Markdown -> Bool
$c>= :: Markdown -> Markdown -> Bool
> :: Markdown -> Markdown -> Bool
$c> :: Markdown -> Markdown -> Bool
<= :: Markdown -> Markdown -> Bool
$c<= :: Markdown -> Markdown -> Bool
< :: Markdown -> Markdown -> Bool
$c< :: Markdown -> Markdown -> Bool
compare :: Markdown -> Markdown -> Ordering
$ccompare :: Markdown -> Markdown -> Ordering
$cp1Ord :: Eq Markdown
Ord, Semigroup Markdown
Markdown
Semigroup Markdown =>
Markdown
-> (Markdown -> Markdown -> Markdown)
-> ([Markdown] -> Markdown)
-> Monoid Markdown
[Markdown] -> Markdown
Markdown -> Markdown -> Markdown
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Markdown] -> Markdown
$cmconcat :: [Markdown] -> Markdown
mappend :: Markdown -> Markdown -> Markdown
$cmappend :: Markdown -> Markdown -> Markdown
mempty :: Markdown
$cmempty :: Markdown
$cp1Monoid :: Semigroup Markdown
Monoid, b -> Markdown -> Markdown
NonEmpty Markdown -> Markdown
Markdown -> Markdown -> Markdown
(Markdown -> Markdown -> Markdown)
-> (NonEmpty Markdown -> Markdown)
-> (forall b. Integral b => b -> Markdown -> Markdown)
-> Semigroup Markdown
forall b. Integral b => b -> Markdown -> Markdown
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Markdown -> Markdown
$cstimes :: forall b. Integral b => b -> Markdown -> Markdown
sconcat :: NonEmpty Markdown -> Markdown
$csconcat :: NonEmpty Markdown -> Markdown
<> :: Markdown -> Markdown -> Markdown
$c<> :: Markdown -> Markdown -> Markdown
Semigroup, String -> Markdown
(String -> Markdown) -> IsString Markdown
forall a. (String -> a) -> IsString a
fromString :: String -> Markdown
$cfromString :: String -> Markdown
IsString, Int -> Markdown -> ShowS
[Markdown] -> ShowS
Markdown -> String
(Int -> Markdown -> ShowS)
-> (Markdown -> String) -> ([Markdown] -> ShowS) -> Show Markdown
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Markdown] -> ShowS
$cshowList :: [Markdown] -> ShowS
show :: Markdown -> String
$cshow :: Markdown -> String
showsPrec :: Int -> Markdown -> ShowS
$cshowsPrec :: Int -> Markdown -> ShowS
Show)

instance ToMarkup Markdown where
    toMarkup :: Markdown -> Markup
toMarkup (Markdown t :: Text
t) = MarkdownSettings -> Text -> Markup
markdown MarkdownSettings
forall a. Default a => a
def Text
t

-- | Convert the given textual markdown content to HTML.
--
-- >>> :set -XOverloadedStrings
-- >>> import Text.Blaze.Html.Renderer.Text
-- >>> renderHtml $ markdown def "# Hello World!"
-- "<h1>Hello World!</h1>"
--
-- >>> renderHtml $ markdown def { msXssProtect = False } "<script>alert('evil')</script>"
-- "<script>alert('evil')</script>"
markdown :: MarkdownSettings -> TL.Text -> Html
markdown :: MarkdownSettings -> Text -> Markup
markdown ms :: MarkdownSettings
ms tl :: Text
tl =
       Markup -> Markup
sanitize
     (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ ConduitT () Void Identity Markup -> Markup
forall r. ConduitT () Void Identity r -> r
runConduitPure
     (ConduitT () Void Identity Markup -> Markup)
-> ConduitT () Void Identity Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Block Markup] -> ConduitT () (Block Markup) Identity ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList [Block Markup]
blocksH
    ConduitT () (Block Markup) Identity ()
-> ConduitM (Block Markup) Void Identity Markup
-> ConduitT () Void Identity Markup
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| MarkdownSettings -> ConduitM (Block Markup) Markup Identity ()
forall (m :: * -> *).
Monad m =>
MarkdownSettings -> ConduitM (Block Markup) Markup m ()
toHtmlB MarkdownSettings
ms
    ConduitM (Block Markup) Markup Identity ()
-> ConduitM Markup Void Identity Markup
-> ConduitM (Block Markup) Void Identity Markup
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Markup -> Markup -> Markup)
-> Markup -> ConduitM Markup Void Identity Markup
forall (m :: * -> *) b a o.
Monad m =>
(b -> a -> b) -> b -> ConduitT a o m b
CL.fold Markup -> Markup -> Markup
forall a. Monoid a => a -> a -> a
mappend Markup
forall a. Monoid a => a
mempty
  where
    sanitize :: Markup -> Markup
sanitize
        | MarkdownSettings -> Bool
msXssProtect MarkdownSettings
ms = Text -> Markup
forall a. ToMarkup a => a -> Markup
preEscapedToMarkup (Text -> Markup) -> (Markup -> Text) -> Markup -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
sanitizeBalance (Text -> Text) -> (Markup -> Text) -> Markup -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict (Text -> Text) -> (Markup -> Text) -> Markup -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Text
renderHtml
        | Bool
otherwise = Markup -> Markup
forall a. a -> a
id
    blocksH :: [Block Html]
    blocksH :: [Block Markup]
blocksH = [Block Text] -> [Block Markup]
processBlocks [Block Text]
blocks

    blocks :: [Block Text]
    blocks :: [Block Text]
blocks = ConduitT () Void Identity [Block Text] -> [Block Text]
forall r. ConduitT () Void Identity r -> r
runConduitPure
           (ConduitT () Void Identity [Block Text] -> [Block Text])
-> ConduitT () Void Identity [Block Text] -> [Block Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> ConduitT () Text Identity ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Text -> [Text]
TL.toChunks Text
tl)
          ConduitT () Text Identity ()
-> ConduitM Text Void Identity [Block Text]
-> ConduitT () Void Identity [Block Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| MarkdownSettings -> ConduitM Text (Block Text) Identity ()
forall (m :: * -> *).
Monad m =>
MarkdownSettings -> ConduitM Text (Block Text) m ()
toBlocks MarkdownSettings
ms
          ConduitM Text (Block Text) Identity ()
-> ConduitM (Block Text) Void Identity [Block Text]
-> ConduitM Text Void Identity [Block Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM (Block Text) Void Identity [Block Text]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume

    processBlocks :: [Block Text] -> [Block Html]
    processBlocks :: [Block Text] -> [Block Markup]
processBlocks = (Block [Inline] -> Block Markup)
-> [Block [Inline]] -> [Block Markup]
forall a b. (a -> b) -> [a] -> [b]
map (([Inline] -> Markup) -> Block [Inline] -> Block Markup
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Inline] -> Markup) -> Block [Inline] -> Block Markup)
-> ([Inline] -> Markup) -> Block [Inline] -> Block Markup
forall a b. (a -> b) -> a -> b
$ MarkdownSettings -> [Inline] -> Markup
toHtmlI MarkdownSettings
ms)
                  ([Block [Inline]] -> [Block Markup])
-> ([Block Text] -> [Block [Inline]])
-> [Block Text]
-> [Block Markup]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarkdownSettings -> [Block [Inline]] -> [Block [Inline]]
msBlockFilter MarkdownSettings
ms
                  ([Block [Inline]] -> [Block [Inline]])
-> ([Block Text] -> [Block [Inline]])
-> [Block Text]
-> [Block [Inline]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block [[Inline]] -> Block [Inline])
-> [Block [[Inline]]] -> [Block [Inline]]
forall a b. (a -> b) -> [a] -> [b]
map (([[Inline]] -> [Inline]) -> Block [[Inline]] -> Block [Inline]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[Inline]] -> [Inline]) -> Block [[Inline]] -> Block [Inline])
-> ([[Inline]] -> [Inline]) -> Block [[Inline]] -> Block [Inline]
forall a b. (a -> b) -> a -> b
$ [Inline] -> [[Inline]] -> [Inline]
forall a. [a] -> [[a]] -> [a]
intercalate [Text -> Inline
InlineHtml "<br>"])
                  ([Block [[Inline]]] -> [Block [Inline]])
-> ([Block Text] -> [Block [[Inline]]])
-> [Block Text]
-> [Block [Inline]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block [Text] -> Block [[Inline]])
-> [Block [Text]] -> [Block [[Inline]]]
forall a b. (a -> b) -> [a] -> [b]
map (([Text] -> [[Inline]]) -> Block [Text] -> Block [[Inline]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Text] -> [[Inline]]) -> Block [Text] -> Block [[Inline]])
-> ([Text] -> [[Inline]]) -> Block [Text] -> Block [[Inline]]
forall a b. (a -> b) -> a -> b
$ (Text -> [Inline]) -> [Text] -> [[Inline]]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> [Inline]) -> [Text] -> [[Inline]])
-> (Text -> [Inline]) -> [Text] -> [[Inline]]
forall a b. (a -> b) -> a -> b
$ RefMap -> Text -> [Inline]
toInline RefMap
refs)
                  ([Block [Text]] -> [Block [[Inline]]])
-> ([Block Text] -> [Block [Text]])
-> [Block Text]
-> [Block [[Inline]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block Text -> Block [Text]) -> [Block Text] -> [Block [Text]]
forall a b. (a -> b) -> [a] -> [b]
map Block Text -> Block [Text]
toBlockLines

    refs :: RefMap
refs =
        [RefMap] -> RefMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([RefMap] -> RefMap) -> [RefMap] -> RefMap
forall a b. (a -> b) -> a -> b
$ (Block Text -> RefMap) -> [Block Text] -> [RefMap]
forall a b. (a -> b) -> [a] -> [b]
map Block Text -> RefMap
forall inline. Block inline -> RefMap
toRef [Block Text]
blocks
      where
        toRef :: Block inline -> RefMap
toRef (BlockReference x :: Text
x y :: Text
y) = Text -> Text -> RefMap
forall k a. k -> a -> Map k a
Map.singleton Text
x Text
y
        toRef _ = RefMap
forall k a. Map k a
Map.empty

data MState = NoState | InList ListType

toHtmlB :: Monad m => MarkdownSettings -> ConduitM (Block Html) Html m ()
toHtmlB :: MarkdownSettings -> ConduitM (Block Markup) Markup m ()
toHtmlB ms :: MarkdownSettings
ms =
    MState -> ConduitM (Block Markup) Markup m ()
forall (m :: * -> *).
Monad m =>
MState -> ConduitT (Block Markup) Markup m ()
loop MState
NoState
  where
    loop :: MState -> ConduitT (Block Markup) Markup m ()
loop state :: MState
state = ConduitT (Block Markup) Markup m (Maybe (Block Markup))
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await ConduitT (Block Markup) Markup m (Maybe (Block Markup))
-> (Maybe (Block Markup) -> ConduitT (Block Markup) Markup m ())
-> ConduitT (Block Markup) Markup m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT (Block Markup) Markup m ()
-> (Block Markup -> ConduitT (Block Markup) Markup m ())
-> Maybe (Block Markup)
-> ConduitT (Block Markup) Markup m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (MState -> ConduitT (Block Markup) Markup m ()
forall (m :: * -> *) i. Monad m => MState -> ConduitT i Markup m ()
closeState MState
state)
        (\x :: Block Markup
x -> do
            MState
state' <- MState -> Block Markup -> ConduitT (Block Markup) Markup m MState
forall (m :: * -> *) inline i.
Monad m =>
MState -> Block inline -> ConduitT i Markup m MState
getState MState
state Block Markup
x
            Markup -> ConduitT (Block Markup) Markup m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Markup -> ConduitT (Block Markup) Markup m ())
-> Markup -> ConduitT (Block Markup) Markup m ()
forall a b. (a -> b) -> a -> b
$ Block Markup -> Markup
go Block Markup
x
            MState -> ConduitT (Block Markup) Markup m ()
loop MState
state')

    closeState :: MState -> ConduitT i Markup m ()
closeState NoState = () -> ConduitT i Markup m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    closeState (InList Unordered) = Markup -> ConduitT i Markup m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Markup -> ConduitT i Markup m ())
-> Markup -> ConduitT i Markup m ()
forall a b. (a -> b) -> a -> b
$ Text -> Markup
escape "</ul>"
    closeState (InList Ordered) = Markup -> ConduitT i Markup m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Markup -> ConduitT i Markup m ())
-> Markup -> ConduitT i Markup m ()
forall a b. (a -> b) -> a -> b
$ Text -> Markup
escape "</ol>"

    getState :: MState -> Block inline -> ConduitT i Markup m MState
getState NoState (BlockList ltype :: ListType
ltype _) = do
        Markup -> ConduitT i Markup m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Markup -> ConduitT i Markup m ())
-> Markup -> ConduitT i Markup m ()
forall a b. (a -> b) -> a -> b
$ Text -> Markup
escape (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$
            case ListType
ltype of
                Unordered -> "<ul>"
                Ordered -> "<ol>"
        MState -> ConduitT i Markup m MState
forall (m :: * -> *) a. Monad m => a -> m a
return (MState -> ConduitT i Markup m MState)
-> MState -> ConduitT i Markup m MState
forall a b. (a -> b) -> a -> b
$ ListType -> MState
InList ListType
ltype
    getState NoState _ = MState -> ConduitT i Markup m MState
forall (m :: * -> *) a. Monad m => a -> m a
return MState
NoState
    getState state :: MState
state@(InList lt1 :: ListType
lt1) b :: Block inline
b@(BlockList lt2 :: ListType
lt2 _)
        | ListType
lt1 ListType -> ListType -> Bool
forall a. Eq a => a -> a -> Bool
== ListType
lt2 = MState -> ConduitT i Markup m MState
forall (m :: * -> *) a. Monad m => a -> m a
return MState
state
        | Bool
otherwise = MState -> ConduitT i Markup m ()
forall (m :: * -> *) i. Monad m => MState -> ConduitT i Markup m ()
closeState MState
state ConduitT i Markup m ()
-> ConduitT i Markup m MState -> ConduitT i Markup m MState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MState -> Block inline -> ConduitT i Markup m MState
getState MState
NoState Block inline
b
    getState state :: MState
state@(InList _) _ = MState -> ConduitT i Markup m ()
forall (m :: * -> *) i. Monad m => MState -> ConduitT i Markup m ()
closeState MState
state ConduitT i Markup m ()
-> ConduitT i Markup m MState -> ConduitT i Markup m MState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MState -> ConduitT i Markup m MState
forall (m :: * -> *) a. Monad m => a -> m a
return MState
NoState

    go :: Block Markup -> Markup
go (BlockPara h :: Markup
h) = Markup -> Markup
H.p Markup
h
    go (BlockPlainText h :: Markup
h) = Markup
h
    go (BlockList _ (Left h :: Markup
h)) = Markup -> Markup
H.li Markup
h
    go (BlockList _ (Right bs :: [Block Markup]
bs)) = Markup -> Markup
H.li (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Block Markup] -> Markup
forall (t :: * -> *). Foldable t => t (Block Markup) -> Markup
blocksToHtml [Block Markup]
bs
    go (BlockHtml t :: Text
t) = Text -> Markup
escape Text
t
    go (BlockCode a :: Maybe Text
a b :: Text
b) = MarkdownSettings -> Maybe Text -> (Text, Markup) -> Markup
msBlockCodeRenderer MarkdownSettings
ms Maybe Text
a (Text -> Text
forall a. a -> a
id (Text -> Text) -> (Text -> Markup) -> Text -> (Text, Markup)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Text -> Markup
forall a. ToMarkup a => a -> Markup
toMarkup (Text -> (Text, Markup)) -> Text -> (Text, Markup)
forall a b. (a -> b) -> a -> b
$ Text
b)
    go (BlockQuote bs :: [Block Markup]
bs) = Markup -> Markup
H.blockquote (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Block Markup] -> Markup
forall (t :: * -> *). Foldable t => t (Block Markup) -> Markup
blocksToHtml [Block Markup]
bs
    go BlockRule = Markup
H.hr
    go (BlockHeading level :: Int
level h :: Markup
h)
        | MarkdownSettings -> Bool
msAddHeadingId MarkdownSettings
ms = Int -> Markup -> Markup
forall a. (Eq a, Num a) => a -> Markup -> Markup
wrap Int
level (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.id (Markup -> AttributeValue
clean Markup
h) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup
h
        | Bool
otherwise         = Int -> Markup -> Markup
forall a. (Eq a, Num a) => a -> Markup -> Markup
wrap Int
level Markup
h
      where
       wrap :: a -> Markup -> Markup
wrap 1 = Markup -> Markup
H.h1
       wrap 2 = Markup -> Markup
H.h2
       wrap 3 = Markup -> Markup
H.h3
       wrap 4 = Markup -> Markup
H.h4
       wrap 5 = Markup -> Markup
H.h5
       wrap _ = Markup -> Markup
H.h6

       isValidChar :: Char -> Bool
isValidChar c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf [Char
c] "-_:."

       clean :: Markup -> AttributeValue
clean = Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (Text -> AttributeValue)
-> (Markup -> Text) -> Markup -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
TL.filter Char -> Bool
isValidChar (Text -> Text) -> (Markup -> Text) -> Markup -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text -> Text
TL.replace " " "-") (Text -> Text) -> (Markup -> Text) -> Markup -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toLower (Text -> Text) -> (Markup -> Text) -> Markup -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Text
renderHtml



    go BlockReference{} = () -> Markup
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    blocksToHtml :: t (Block Markup) -> Markup
blocksToHtml bs :: t (Block Markup)
bs = ConduitT () Void Identity Markup -> Markup
forall r. ConduitT () Void Identity r -> r
runConduitPure (ConduitT () Void Identity Markup -> Markup)
-> ConduitT () Void Identity Markup -> Markup
forall a b. (a -> b) -> a -> b
$ (Block Markup -> ConduitT () (Block Markup) Identity ())
-> t (Block Markup) -> ConduitT () (Block Markup) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block Markup -> ConduitT () (Block Markup) Identity ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield t (Block Markup)
bs ConduitT () (Block Markup) Identity ()
-> ConduitM (Block Markup) Void Identity Markup
-> ConduitT () Void Identity Markup
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| MarkdownSettings -> ConduitM (Block Markup) Markup Identity ()
forall (m :: * -> *).
Monad m =>
MarkdownSettings -> ConduitM (Block Markup) Markup m ()
toHtmlB MarkdownSettings
ms ConduitM (Block Markup) Markup Identity ()
-> ConduitM Markup Void Identity Markup
-> ConduitM (Block Markup) Void Identity Markup
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Markup -> Markup -> Markup)
-> Markup -> ConduitM Markup Void Identity Markup
forall (m :: * -> *) b a o.
Monad m =>
(b -> a -> b) -> b -> ConduitT a o m b
CL.fold Markup -> Markup -> Markup
forall a. Monoid a => a -> a -> a
mappend Markup
forall a. Monoid a => a
mempty

escape :: Text -> Html
escape :: Text -> Markup
escape = Text -> Markup
forall a. ToMarkup a => a -> Markup
preEscapedToMarkup

toHtmlI :: MarkdownSettings -> [Inline] -> Html
toHtmlI :: MarkdownSettings -> [Inline] -> Markup
toHtmlI ms :: MarkdownSettings
ms is0 :: [Inline]
is0
    | MarkdownSettings -> Bool
msXssProtect MarkdownSettings
ms = Text -> Markup
escape (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Text
sanitizeBalance (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Markup -> Text
renderHtml Markup
final
    | Bool
otherwise = Markup
final
  where
    final :: Markup
final = [Inline] -> Markup
gos [Inline]
is0
    gos :: [Inline] -> Markup
gos = [Markup] -> Markup
forall a. Monoid a => [a] -> a
mconcat ([Markup] -> Markup)
-> ([Inline] -> [Markup]) -> [Inline] -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Markup) -> [Inline] -> [Markup]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Markup
go

    go :: Inline -> Markup
go (InlineText t :: Text
t) = Text -> Markup
forall a. ToMarkup a => a -> Markup
toMarkup Text
t
    go (InlineItalic is :: [Inline]
is) = Markup -> Markup
H.i (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Inline] -> Markup
gos [Inline]
is
    go (InlineBold is :: [Inline]
is) = Markup -> Markup
H.b (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Inline] -> Markup
gos [Inline]
is
    go (InlineCode t :: Text
t) = Markup -> Markup
H.code (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
forall a. ToMarkup a => a -> Markup
toMarkup Text
t
    go (InlineLink url :: Text
url mtitle :: Maybe Text
mtitle content :: [Inline]
content) =
        Markup -> Markup
H.a
        (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
url)
        (Markup -> Markup) -> (Bool, Attribute) -> Markup -> Markup
forall h. Attributable h => h -> (Bool, Attribute) -> h
H.!? (MarkdownSettings -> Bool
msLinkNewTab MarkdownSettings
ms, AttributeValue -> Attribute
HA.target "_blank")
        (Markup -> Markup) -> (Bool, Attribute) -> Markup -> Markup
forall h. Attributable h => h -> (Bool, Attribute) -> h
H.!? (MarkdownSettings -> Bool
msNoFollowExternal MarkdownSettings
ms Bool -> Bool -> Bool
&& Text -> Bool
isExternalLink Text
url, AttributeValue -> Attribute
HA.rel "nofollow")
        (Markup -> Markup) -> (Bool, Attribute) -> Markup -> Markup
forall h. Attributable h => h -> (Bool, Attribute) -> h
H.!? (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
mtitle, AttributeValue -> Attribute
HA.title (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ AttributeValue
-> (Text -> AttributeValue) -> Maybe Text -> AttributeValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> AttributeValue
forall a. HasCallStack => String -> a
error "impossible") Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Maybe Text
mtitle)
        (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Inline] -> Markup
gos [Inline]
content
    go (InlineImage url :: Text
url Nothing content :: Text
content) = Markup
H.img Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.src (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
url) Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.alt (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
content)
    go (InlineImage url :: Text
url (Just title :: Text
title) content :: Text
content) = Markup
H.img Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.src (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
url) Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.alt (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
content) Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.title (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
title)
    go (InlineHtml t :: Text
t) = Text -> Markup
escape Text
t
    go (InlineFootnoteRef x :: Integer
x) = let ishown :: Text
ishown = String -> Text
TL.pack (Integer -> String
forall a. Show a => a -> String
show Integer
x)
                                in Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ "#footnote-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown)
                                       (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.id (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ "ref-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
forall a. ToMarkup a => a -> Markup
H.toHtml (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ "[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "]"
    go (InlineFootnote x :: Integer
x) = let ishown :: Text
ishown = String -> Text
TL.pack (Integer -> String
forall a. Show a => a -> String
show Integer
x)
                             in Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ "#ref-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown)
                                    (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.id (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ "footnote-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
forall a. ToMarkup a => a -> Markup
H.toHtml (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ "[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "]"

-- | For external links, add the rel="nofollow" attribute
--
-- @since 0.1.16
setNoFollowExternal :: MarkdownSettings -> MarkdownSettings
setNoFollowExternal :: MarkdownSettings -> MarkdownSettings
setNoFollowExternal ms :: MarkdownSettings
ms = MarkdownSettings
ms { msNoFollowExternal :: Bool
msNoFollowExternal = Bool
True }

-- | Is the given URL an external link?
isExternalLink :: Text -> Bool
isExternalLink :: Text -> Bool
isExternalLink = Text -> Text -> Bool
T.isInfixOf "//"