{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
module Text.Markdown
(
markdown
, MarkdownSettings
, defaultMarkdownSettings
, msXssProtect
, msStandaloneHtml
, msFencedHandlers
, msBlockCodeRenderer
, msLinkNewTab
, msBlankBeforeBlockquote
, msBlockFilter
, msAddHeadingId
, setNoFollowExternal
, Markdown (..)
, FencedHandler (..)
, codeFencedHandler
, htmlFencedHandler
, 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)
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
$c== :: Markdown -> Markdown -> Bool
== :: Markdown -> Markdown -> Bool
$c/= :: Markdown -> Markdown -> Bool
/= :: 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
$ccompare :: Markdown -> Markdown -> Ordering
compare :: Markdown -> Markdown -> Ordering
$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
>= :: Markdown -> Markdown -> Bool
$cmax :: Markdown -> Markdown -> Markdown
max :: Markdown -> Markdown -> Markdown
$cmin :: Markdown -> Markdown -> Markdown
min :: Markdown -> Markdown -> 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
$cmempty :: Markdown
mempty :: Markdown
$cmappend :: Markdown -> Markdown -> Markdown
mappend :: Markdown -> Markdown -> Markdown
$cmconcat :: [Markdown] -> Markdown
mconcat :: [Markdown] -> Markdown
Monoid, 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
$c<> :: Markdown -> Markdown -> Markdown
<> :: Markdown -> Markdown -> Markdown
$csconcat :: NonEmpty Markdown -> Markdown
sconcat :: NonEmpty Markdown -> Markdown
$cstimes :: forall b. Integral b => b -> Markdown -> Markdown
stimes :: forall b. Integral b => b -> Markdown -> Markdown
Semigroup, String -> Markdown
(String -> Markdown) -> IsString Markdown
forall a. (String -> a) -> IsString a
$cfromString :: String -> Markdown
fromString :: 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
$cshowsPrec :: Int -> Markdown -> ShowS
showsPrec :: Int -> Markdown -> ShowS
$cshow :: Markdown -> String
show :: Markdown -> String
$cshowList :: [Markdown] -> ShowS
showList :: [Markdown] -> ShowS
Show)
instance ToMarkup Markdown where
toMarkup :: Markdown -> Html
toMarkup (Markdown Text
t) = MarkdownSettings -> Text -> Html
markdown MarkdownSettings
forall a. Default a => a
def Text
t
markdown :: MarkdownSettings -> TL.Text -> Html
markdown :: MarkdownSettings -> Text -> Html
markdown MarkdownSettings
ms Text
tl =
Html -> Html
sanitize
(Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ConduitT () Void Identity Html -> Html
forall r. ConduitT () Void Identity r -> r
runConduitPure
(ConduitT () Void Identity Html -> Html)
-> ConduitT () Void Identity Html -> Html
forall a b. (a -> b) -> a -> b
$ [Block Html] -> ConduitT () (Block Html) Identity ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList [Block Html]
blocksH
ConduitT () (Block Html) Identity ()
-> ConduitT (Block Html) Void Identity Html
-> ConduitT () Void Identity Html
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| MarkdownSettings -> ConduitM (Block Html) Html Identity ()
forall (m :: * -> *).
Monad m =>
MarkdownSettings -> ConduitM (Block Html) Html m ()
toHtmlB MarkdownSettings
ms
ConduitM (Block Html) Html Identity ()
-> ConduitT Html Void Identity Html
-> ConduitT (Block Html) Void Identity Html
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Html -> Html -> Html) -> Html -> ConduitT Html Void Identity Html
forall (m :: * -> *) b a o.
Monad m =>
(b -> a -> b) -> b -> ConduitT a o m b
CL.fold Html -> Html -> Html
forall a. Monoid a => a -> a -> a
mappend Html
forall a. Monoid a => a
mempty
where
sanitize :: Html -> Html
sanitize
| MarkdownSettings -> Bool
msXssProtect MarkdownSettings
ms = Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToMarkup (Text -> Html) -> (Html -> Text) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
sanitizeBalance (Text -> Text) -> (Html -> Text) -> Html -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict (Text -> Text) -> (Html -> Text) -> Html -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
renderHtml
| Bool
otherwise = Html -> Html
forall a. a -> a
id
blocksH :: [Block Html]
blocksH :: [Block Html]
blocksH = [Block Text] -> [Block Html]
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 ()
-> ConduitT Text Void Identity [Block Text]
-> ConduitT () Void Identity [Block Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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 ()
-> ConduitT (Block Text) Void Identity [Block Text]
-> ConduitT Text Void Identity [Block Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT (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 Html]
processBlocks = (Block [Inline] -> Block Html) -> [Block [Inline]] -> [Block Html]
forall a b. (a -> b) -> [a] -> [b]
map (([Inline] -> Html) -> Block [Inline] -> Block Html
forall a b. (a -> b) -> Block a -> Block b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Inline] -> Html) -> Block [Inline] -> Block Html)
-> ([Inline] -> Html) -> Block [Inline] -> Block Html
forall a b. (a -> b) -> a -> b
$ MarkdownSettings -> [Inline] -> Html
toHtmlI MarkdownSettings
ms)
([Block [Inline]] -> [Block Html])
-> ([Block Text] -> [Block [Inline]])
-> [Block Text]
-> [Block Html]
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 a b. (a -> b) -> Block a -> Block b
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 Text
"<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 a b. (a -> b) -> Block a -> Block b
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 Text
x Text
y) = Text -> Text -> RefMap
forall k a. k -> a -> Map k a
Map.singleton Text
x Text
y
toRef Block inline
_ = RefMap
forall k a. Map k a
Map.empty
data MState = NoState | InList ListType
toHtmlB :: Monad m => MarkdownSettings -> ConduitM (Block Html) Html m ()
toHtmlB :: forall (m :: * -> *).
Monad m =>
MarkdownSettings -> ConduitM (Block Html) Html m ()
toHtmlB MarkdownSettings
ms =
MState -> ConduitT (Block Html) Html m ()
forall {m :: * -> *}.
Monad m =>
MState -> ConduitT (Block Html) Html m ()
loop MState
NoState
where
loop :: MState -> ConduitT (Block Html) Html m ()
loop MState
state = ConduitT (Block Html) Html m (Maybe (Block Html))
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT (Block Html) Html m (Maybe (Block Html))
-> (Maybe (Block Html) -> ConduitT (Block Html) Html m ())
-> ConduitT (Block Html) Html m ()
forall a b.
ConduitT (Block Html) Html m a
-> (a -> ConduitT (Block Html) Html m b)
-> ConduitT (Block Html) Html m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT (Block Html) Html m ()
-> (Block Html -> ConduitT (Block Html) Html m ())
-> Maybe (Block Html)
-> ConduitT (Block Html) Html m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(MState -> ConduitT (Block Html) Html m ()
forall {m :: * -> *} {i}. Monad m => MState -> ConduitT i Html m ()
closeState MState
state)
(\Block Html
x -> do
MState
state' <- MState -> Block Html -> ConduitT (Block Html) Html m MState
forall {m :: * -> *} {inline} {i}.
Monad m =>
MState -> Block inline -> ConduitT i Html m MState
getState MState
state Block Html
x
Html -> ConduitT (Block Html) Html m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Html -> ConduitT (Block Html) Html m ())
-> Html -> ConduitT (Block Html) Html m ()
forall a b. (a -> b) -> a -> b
$ Block Html -> Html
go Block Html
x
MState -> ConduitT (Block Html) Html m ()
loop MState
state')
closeState :: MState -> ConduitT i Html m ()
closeState MState
NoState = () -> ConduitT i Html m ()
forall a. a -> ConduitT i Html m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
closeState (InList ListType
Unordered) = Html -> ConduitT i Html m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Html -> ConduitT i Html m ()) -> Html -> ConduitT i Html m ()
forall a b. (a -> b) -> a -> b
$ Text -> Html
escape Text
"</ul>"
closeState (InList ListType
Ordered) = Html -> ConduitT i Html m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Html -> ConduitT i Html m ()) -> Html -> ConduitT i Html m ()
forall a b. (a -> b) -> a -> b
$ Text -> Html
escape Text
"</ol>"
getState :: MState -> Block inline -> ConduitT i Html m MState
getState MState
NoState (BlockList ListType
ltype Either inline [Block inline]
_) = do
Html -> ConduitT i Html m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Html -> ConduitT i Html m ()) -> Html -> ConduitT i Html m ()
forall a b. (a -> b) -> a -> b
$ Text -> Html
escape (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$
case ListType
ltype of
ListType
Unordered -> Text
"<ul>"
ListType
Ordered -> Text
"<ol>"
MState -> ConduitT i Html m MState
forall a. a -> ConduitT i Html m a
forall (m :: * -> *) a. Monad m => a -> m a
return (MState -> ConduitT i Html m MState)
-> MState -> ConduitT i Html m MState
forall a b. (a -> b) -> a -> b
$ ListType -> MState
InList ListType
ltype
getState MState
NoState Block inline
_ = MState -> ConduitT i Html m MState
forall a. a -> ConduitT i Html m a
forall (m :: * -> *) a. Monad m => a -> m a
return MState
NoState
getState state :: MState
state@(InList ListType
lt1) b :: Block inline
b@(BlockList ListType
lt2 Either inline [Block inline]
_)
| ListType
lt1 ListType -> ListType -> Bool
forall a. Eq a => a -> a -> Bool
== ListType
lt2 = MState -> ConduitT i Html m MState
forall a. a -> ConduitT i Html m a
forall (m :: * -> *) a. Monad m => a -> m a
return MState
state
| Bool
otherwise = MState -> ConduitT i Html m ()
forall {m :: * -> *} {i}. Monad m => MState -> ConduitT i Html m ()
closeState MState
state ConduitT i Html m ()
-> ConduitT i Html m MState -> ConduitT i Html m MState
forall a b.
ConduitT i Html m a -> ConduitT i Html m b -> ConduitT i Html m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MState -> Block inline -> ConduitT i Html m MState
getState MState
NoState Block inline
b
getState state :: MState
state@(InList ListType
_) Block inline
_ = MState -> ConduitT i Html m ()
forall {m :: * -> *} {i}. Monad m => MState -> ConduitT i Html m ()
closeState MState
state ConduitT i Html m ()
-> ConduitT i Html m MState -> ConduitT i Html m MState
forall a b.
ConduitT i Html m a -> ConduitT i Html m b -> ConduitT i Html m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MState -> ConduitT i Html m MState
forall a. a -> ConduitT i Html m a
forall (m :: * -> *) a. Monad m => a -> m a
return MState
NoState
go :: Block Html -> Html
go (BlockPara Html
h) = Html -> Html
H.p Html
h
go (BlockPlainText Html
h) = Html
h
go (BlockList ListType
_ (Left Html
h)) = Html -> Html
H.li Html
h
go (BlockList ListType
_ (Right [Block Html]
bs)) = Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Block Html] -> Html
forall {t :: * -> *}. Foldable t => t (Block Html) -> Html
blocksToHtml [Block Html]
bs
go (BlockHtml Text
t) = Text -> Html
escape Text
t
go (BlockCode Maybe Text
a Text
b) = MarkdownSettings -> Maybe Text -> (Text, Html) -> Html
msBlockCodeRenderer MarkdownSettings
ms Maybe Text
a (Text -> Text
forall a. a -> a
id (Text -> Text) -> (Text -> Html) -> Text -> (Text, Html)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Text -> Html
forall a. ToMarkup a => a -> Html
toMarkup (Text -> (Text, Html)) -> Text -> (Text, Html)
forall a b. (a -> b) -> a -> b
$ Text
b)
go (BlockQuote [Block Html]
bs) = Html -> Html
H.blockquote (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Block Html] -> Html
forall {t :: * -> *}. Foldable t => t (Block Html) -> Html
blocksToHtml [Block Html]
bs
go Block Html
BlockRule = Html
H.hr
go (BlockHeading Int
level Html
h)
| MarkdownSettings -> Bool
msAddHeadingId MarkdownSettings
ms = Int -> Html -> Html
forall {a}. (Eq a, Num a) => a -> Html -> Html
wrap Int
level (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.id (Html -> AttributeValue
clean Html
h) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
h
| Bool
otherwise = Int -> Html -> Html
forall {a}. (Eq a, Num a) => a -> Html -> Html
wrap Int
level Html
h
where
wrap :: a -> Html -> Html
wrap a
1 = Html -> Html
H.h1
wrap a
2 = Html -> Html
H.h2
wrap a
3 = Html -> Html
H.h3
wrap a
4 = Html -> Html
H.h4
wrap a
5 = Html -> Html
H.h5
wrap a
_ = Html -> Html
H.h6
isValidChar :: Char -> Bool
isValidChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf [Char
c] String
"-_:."
clean :: Html -> AttributeValue
clean = Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (Text -> AttributeValue)
-> (Html -> Text) -> Html -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
TL.filter Char -> Bool
isValidChar (Text -> Text) -> (Html -> Text) -> Html -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
TL.replace Text
" " Text
"-") (Text -> Text) -> (Html -> Text) -> Html -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toLower (Text -> Text) -> (Html -> Text) -> Html -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
renderHtml
go BlockReference{} = () -> Html
forall a. a -> MarkupM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
blocksToHtml :: t (Block Html) -> Html
blocksToHtml t (Block Html)
bs = ConduitT () Void Identity Html -> Html
forall r. ConduitT () Void Identity r -> r
runConduitPure (ConduitT () Void Identity Html -> Html)
-> ConduitT () Void Identity Html -> Html
forall a b. (a -> b) -> a -> b
$ (Block Html -> ConduitT () (Block Html) Identity ())
-> t (Block Html) -> ConduitT () (Block Html) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block Html -> ConduitT () (Block Html) Identity ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield t (Block Html)
bs ConduitT () (Block Html) Identity ()
-> ConduitT (Block Html) Void Identity Html
-> ConduitT () Void Identity Html
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| MarkdownSettings -> ConduitM (Block Html) Html Identity ()
forall (m :: * -> *).
Monad m =>
MarkdownSettings -> ConduitM (Block Html) Html m ()
toHtmlB MarkdownSettings
ms ConduitM (Block Html) Html Identity ()
-> ConduitT Html Void Identity Html
-> ConduitT (Block Html) Void Identity Html
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Html -> Html -> Html) -> Html -> ConduitT Html Void Identity Html
forall (m :: * -> *) b a o.
Monad m =>
(b -> a -> b) -> b -> ConduitT a o m b
CL.fold Html -> Html -> Html
forall a. Monoid a => a -> a -> a
mappend Html
forall a. Monoid a => a
mempty
escape :: Text -> Html
escape :: Text -> Html
escape = Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToMarkup
toHtmlI :: MarkdownSettings -> [Inline] -> Html
toHtmlI :: MarkdownSettings -> [Inline] -> Html
toHtmlI MarkdownSettings
ms [Inline]
is0
| MarkdownSettings -> Bool
msXssProtect MarkdownSettings
ms = Text -> Html
escape (Text -> Html) -> Text -> Html
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
$ Html -> Text
renderHtml Html
final
| Bool
otherwise = Html
final
where
final :: Html
final = [Inline] -> Html
gos [Inline]
is0
gos :: [Inline] -> Html
gos = [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> ([Inline] -> [Html]) -> [Inline] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Html) -> [Inline] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Html
go
go :: Inline -> Html
go (InlineText Text
t) = Text -> Html
forall a. ToMarkup a => a -> Html
toMarkup Text
t
go (InlineItalic [Inline]
is) = Html -> Html
H.i (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Inline] -> Html
gos [Inline]
is
go (InlineBold [Inline]
is) = Html -> Html
H.b (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Inline] -> Html
gos [Inline]
is
go (InlineCode Text
t) = Html -> Html
H.code (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
toMarkup Text
t
go (InlineLink Text
url Maybe Text
mtitle [Inline]
content) =
Html -> Html
H.a
(Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
url)
(Html -> Html) -> (Bool, Attribute) -> Html -> Html
forall h. Attributable h => h -> (Bool, Attribute) -> h
H.!? (MarkdownSettings -> Bool
msLinkNewTab MarkdownSettings
ms, AttributeValue -> Attribute
HA.target AttributeValue
"_blank")
(Html -> Html) -> (Bool, Attribute) -> Html -> Html
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 AttributeValue
"nofollow")
(Html -> Html) -> (Bool, Attribute) -> Html -> Html
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 String
"impossible") Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Maybe Text
mtitle)
(Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ [Inline] -> Html
gos [Inline]
content
go (InlineImage Text
url Maybe Text
Nothing Text
content) = Html
H.img Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.src (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
url) Html -> Attribute -> Html
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 Text
url (Just Text
title) Text
content) = Html
H.img Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.src (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
url) Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.alt (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
content) Html -> Attribute -> Html
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 Text
t) = Text -> Html
escape Text
t
go (InlineFootnoteRef Integer
x) = let ishown :: Text
ishown = String -> Text
TL.pack (Integer -> String
forall a. Show a => a -> String
show Integer
x)
in Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
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
$ Text
"#footnote-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown)
(Html -> Html) -> Attribute -> Html -> Html
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
$ Text
"ref-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
go (InlineFootnote Integer
x) = let ishown :: Text
ishown = String -> Text
TL.pack (Integer -> String
forall a. Show a => a -> String
show Integer
x)
in Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
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
$ Text
"#ref-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown)
(Html -> Html) -> Attribute -> Html -> Html
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
$ Text
"footnote-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
setNoFollowExternal :: MarkdownSettings -> MarkdownSettings
setNoFollowExternal :: MarkdownSettings -> MarkdownSettings
setNoFollowExternal MarkdownSettings
ms = MarkdownSettings
ms { msNoFollowExternal :: Bool
msNoFollowExternal = Bool
True }
isExternalLink :: Text -> Bool
isExternalLink :: Text -> Bool
isExternalLink = Text -> Text -> Bool
T.isInfixOf Text
"//"