{-# LANGUAGE OverloadedStrings #-} module Text.Markdown.Types where import Data.Text (Text) import qualified Data.Text as T import Data.Default (Default (def)) import Data.Set (Set, empty) import Data.Map (Map, singleton) import Data.Monoid (mappend) import Text.Blaze.Html (Html) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as HA -- | A settings type providing various configuration options. -- -- See <http://www.yesodweb.com/book/settings-types> for more information on -- settings types. In general, you can use @def@. data MarkdownSettings = MarkdownSettings { msXssProtect :: Bool -- ^ Whether to automatically apply XSS protection to embedded HTML. Default: @True@. , msStandaloneHtml :: Set Text -- ^ HTML snippets which stand on their own. We do not require a blank line following these pieces of HTML. -- -- Default: empty set. -- -- Since: 0.1.2 , msFencedHandlers :: Map Text (Text -> FencedHandler) -- ^ Handlers for the special \"fenced\" format. This is most commonly -- used for fenced code, e.g.: -- -- > ```haskell -- > main = putStrLn "Hello" -- > ``` -- -- This is an extension of Markdown, but a fairly commonly used one. -- -- This setting allows you to create new kinds of fencing. Fencing goes -- into two categories: parsed and raw. Code fencing would be in the raw -- category, where the contents are not treated as Markdown. Parsed will -- treat the contents as Markdown and allow you to perform some kind of -- modifcation to it. -- -- For example, to create a new @\@\@\@@ fencing which wraps up the -- contents in an @article@ tag, you could use: -- -- > def { msFencedHandlers = htmlFencedHandler "@@@" (const "<article>") (const "</article") -- > `Map.union` msFencedHandlers def -- > } -- -- Default: code fencing for @```@ and @~~~@. -- -- Since: 0.1.2 , msBlockCodeRenderer :: Maybe Text -> (Text,Html) -> Html -- ^ A rendering function through which code blocks are passed. -- -- The arguments are the block's language, if any, and the tuple -- @(unrendered content, rendered content)@. For example, if you wanted to pass -- code blocks in your markdown text through a highlighter like @highlighting-kate@, -- you might do something like: -- -- >>> :set -XOverloadedStrings -- >>> let renderer lang (src,_) = formatHtmlBlock defaultFormatOpts $ highlightAs (maybe "text" unpack lang) $ unpack src -- >>> let md = markdown def { msBlockCodeRenderer = renderer } "``` haskell\nmain = putStrLn \"Hello world!\"\n```" -- >>> putStrLn $ renderHtml md -- <pre class="sourceCode"><code class="sourceCode">main <span class="fu">=</span> <span class="fu">putStrLn</span> <span class="st">&quot;Hello world!&quot;</span></code></pre> -- -- Since: 0.1.2.1 , msLinkNewTab :: Bool -- ^ If @True@, all generated links have the attribute target=_blank set, -- causing them to be opened in a new tab or window. -- -- Default: @False@ -- -- Since 0.1.4 , msBlankBeforeBlockquote :: Bool -- ^ If @True@, a blank line is required before the start of a blockquote. Standard -- markdown syntax does not require a blank line before a blockquote, but it is all -- too easy for a > to end up at the beginning of a line by accident. -- -- Default: @True@ -- -- Since 0.1.5 , msBlockFilter :: [Block [Inline]] -> [Block [Inline]] -- ^ A function to filter and/or modify parsed blocks before they are -- written to Html -- -- Default: @id@ -- -- Since 0.1.7 } -- | See 'msFencedHandlers. -- -- Since 0.1.2 data FencedHandler = FHRaw (Text -> [Block Text]) -- ^ Wrap up the given raw content. | FHParsed ([Block Text] -> [Block Text]) -- ^ Wrap up the given parsed content. instance Default MarkdownSettings where def = MarkdownSettings { msXssProtect = True , msStandaloneHtml = empty , msFencedHandlers = codeFencedHandler "```" `mappend` codeFencedHandler "~~~" , msBlockCodeRenderer = \lang (_,rendered) -> case lang of Just l -> H.pre $ H.code H.! HA.class_ (H.toValue l) $ rendered Nothing -> H.pre $ H.code $ rendered , msLinkNewTab = False , msBlankBeforeBlockquote = True , msBlockFilter = id } -- | Helper for creating a 'FHRaw'. -- -- Since 0.1.2 codeFencedHandler :: Text -- ^ Delimiter -> Map Text (Text -> FencedHandler) codeFencedHandler key = singleton key $ \lang -> FHRaw $ return . BlockCode (if T.null lang then Nothing else Just lang) -- | Helper for creating a 'FHParsed'. -- -- Note that the start and end parameters take a @Text@ parameter; this is the -- text following the delimiter. For example, with the markdown: -- -- > @@@ foo -- -- @foo@ would be passed to start and end. -- -- Since 0.1.2 htmlFencedHandler :: Text -- ^ Delimiter -> (Text -> Text) -- ^ start HTML -> (Text -> Text) -- ^ end HTML -> Map Text (Text -> FencedHandler) htmlFencedHandler key start end = singleton key $ \lang -> FHParsed $ \blocks -> BlockHtml (start lang) : blocks ++ [BlockHtml $ end lang] data ListType = Ordered | Unordered deriving (Show, Eq) data Block inline = BlockPara inline | BlockList ListType (Either inline [Block inline]) | BlockCode (Maybe Text) Text | BlockQuote [Block inline] | BlockHtml Text | BlockRule | BlockHeading Int inline | BlockReference Text Text | BlockPlainText inline deriving (Show, Eq) instance Functor Block where fmap f (BlockPara i) = BlockPara (f i) fmap f (BlockList lt (Left i)) = BlockList lt $ Left $ f i fmap f (BlockList lt (Right bs)) = BlockList lt $ Right $ map (fmap f) bs fmap _ (BlockCode a b) = BlockCode a b fmap f (BlockQuote bs) = BlockQuote $ map (fmap f) bs fmap _ (BlockHtml t) = BlockHtml t fmap _ BlockRule = BlockRule fmap f (BlockHeading level i) = BlockHeading level (f i) fmap _ (BlockReference x y) = BlockReference x y fmap f (BlockPlainText x) = BlockPlainText (f x) data Inline = InlineText Text | InlineItalic [Inline] | InlineBold [Inline] | InlineCode Text | InlineHtml Text | InlineLink Text (Maybe Text) [Inline] -- ^ URL, title, content | InlineImage Text (Maybe Text) Text -- ^ URL, title, content | InlineFootnoteRef Integer -- ^ The footnote reference in the body | InlineFootnote Integer deriving (Show, Eq)