{-# 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
    { MarkdownSettings -> Bool
msXssProtect :: Bool
      -- ^ Whether to automatically apply XSS protection to embedded HTML. Default: @True@.
    , MarkdownSettings -> Set Text
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
    , MarkdownSettings -> Map Text (Text -> FencedHandler)
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
    , MarkdownSettings -> Maybe Text -> (Text, Html) -> Html
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
    , MarkdownSettings -> Bool
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

    , MarkdownSettings -> Bool
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
    , MarkdownSettings -> [Block [Inline]] -> [Block [Inline]]
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

    , MarkdownSettings -> Bool
msAddHeadingId :: Bool
      -- ^ If @True@, an @id@ attribute is added to the heading tag with the value equal to
      -- the text with only valid CSS identifier characters.
      --
      -- > ## Executive Summary
      --
      -- > <h2 id="executive-summary">Executive Summary</h2>
      --
      -- Default: @False@
      --
      -- Since 0.1.13

    , MarkdownSettings -> Bool
msNoFollowExternal :: Bool
    }

-- | 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.

-- | @since 0.1.15
defaultMarkdownSettings :: MarkdownSettings
defaultMarkdownSettings :: MarkdownSettings
defaultMarkdownSettings = MarkdownSettings :: Bool
-> Set Text
-> Map Text (Text -> FencedHandler)
-> (Maybe Text -> (Text, Html) -> Html)
-> Bool
-> Bool
-> ([Block [Inline]] -> [Block [Inline]])
-> Bool
-> Bool
-> MarkdownSettings
MarkdownSettings
        { msXssProtect :: Bool
msXssProtect = Bool
True
        , msStandaloneHtml :: Set Text
msStandaloneHtml = Set Text
forall a. Set a
empty
        , msFencedHandlers :: Map Text (Text -> FencedHandler)
msFencedHandlers = Text -> Map Text (Text -> FencedHandler)
codeFencedHandler Text
"```" Map Text (Text -> FencedHandler)
-> Map Text (Text -> FencedHandler)
-> Map Text (Text -> FencedHandler)
forall a. Monoid a => a -> a -> a
`mappend` Text -> Map Text (Text -> FencedHandler)
codeFencedHandler Text
"~~~"
        , msBlockCodeRenderer :: Maybe Text -> (Text, Html) -> Html
msBlockCodeRenderer =
            \Maybe Text
lang (Text
_,Html
rendered) -> case Maybe Text
lang of
                                       Just Text
l -> Html -> Html
H.pre (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.code (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.class_ (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
l) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
rendered
                                       Maybe Text
Nothing -> Html -> Html
H.pre (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.code (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
rendered
        , msLinkNewTab :: Bool
msLinkNewTab = Bool
False
        , msBlankBeforeBlockquote :: Bool
msBlankBeforeBlockquote = Bool
True
        , msBlockFilter :: [Block [Inline]] -> [Block [Inline]]
msBlockFilter = [Block [Inline]] -> [Block [Inline]]
forall a. a -> a
id
        , msAddHeadingId :: Bool
msAddHeadingId = Bool
False
        , msNoFollowExternal :: Bool
msNoFollowExternal = Bool
False
        }

instance Default MarkdownSettings where
    def :: MarkdownSettings
def = MarkdownSettings
defaultMarkdownSettings

-- | Helper for creating a 'FHRaw'.
--
-- Since 0.1.2
codeFencedHandler :: Text -- ^ Delimiter
                  -> Map Text (Text -> FencedHandler)
codeFencedHandler :: Text -> Map Text (Text -> FencedHandler)
codeFencedHandler Text
key = Text -> (Text -> FencedHandler) -> Map Text (Text -> FencedHandler)
forall k a. k -> a -> Map k a
singleton Text
key ((Text -> FencedHandler) -> Map Text (Text -> FencedHandler))
-> (Text -> FencedHandler) -> Map Text (Text -> FencedHandler)
forall a b. (a -> b) -> a -> b
$ \Text
lang -> (Text -> [Block Text]) -> FencedHandler
FHRaw ((Text -> [Block Text]) -> FencedHandler)
-> (Text -> [Block Text]) -> FencedHandler
forall a b. (a -> b) -> a -> b
$
    Block Text -> [Block Text]
forall (m :: * -> *) a. Monad m => a -> m a
return (Block Text -> [Block Text])
-> (Text -> Block Text) -> Text -> [Block Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Text -> Block Text
forall inline. Maybe Text -> Text -> Block inline
BlockCode (if Text -> Bool
T.null Text
lang then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
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 :: Text
-> (Text -> Text)
-> (Text -> Text)
-> Map Text (Text -> FencedHandler)
htmlFencedHandler Text
key Text -> Text
start Text -> Text
end = Text -> (Text -> FencedHandler) -> Map Text (Text -> FencedHandler)
forall k a. k -> a -> Map k a
singleton Text
key ((Text -> FencedHandler) -> Map Text (Text -> FencedHandler))
-> (Text -> FencedHandler) -> Map Text (Text -> FencedHandler)
forall a b. (a -> b) -> a -> b
$ \Text
lang -> ([Block Text] -> [Block Text]) -> FencedHandler
FHParsed (([Block Text] -> [Block Text]) -> FencedHandler)
-> ([Block Text] -> [Block Text]) -> FencedHandler
forall a b. (a -> b) -> a -> b
$ \[Block Text]
blocks ->
      Text -> Block Text
forall inline. Text -> Block inline
BlockHtml (Text -> Text
start Text
lang)
    Block Text -> [Block Text] -> [Block Text]
forall a. a -> [a] -> [a]
: [Block Text]
blocks
   [Block Text] -> [Block Text] -> [Block Text]
forall a. [a] -> [a] -> [a]
++ [Text -> Block Text
forall inline. Text -> Block inline
BlockHtml (Text -> Block Text) -> Text -> Block Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
end Text
lang]

data ListType = Ordered | Unordered
  deriving (Int -> ListType -> ShowS
[ListType] -> ShowS
ListType -> String
(Int -> ListType -> ShowS)
-> (ListType -> String) -> ([ListType] -> ShowS) -> Show ListType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ListType] -> ShowS
$cshowList :: [ListType] -> ShowS
show :: ListType -> String
$cshow :: ListType -> String
showsPrec :: Int -> ListType -> ShowS
$cshowsPrec :: Int -> ListType -> ShowS
Show, ListType -> ListType -> Bool
(ListType -> ListType -> Bool)
-> (ListType -> ListType -> Bool) -> Eq ListType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ListType -> ListType -> Bool
$c/= :: ListType -> ListType -> Bool
== :: ListType -> ListType -> Bool
$c== :: ListType -> ListType -> Bool
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 (Int -> Block inline -> ShowS
[Block inline] -> ShowS
Block inline -> String
(Int -> Block inline -> ShowS)
-> (Block inline -> String)
-> ([Block inline] -> ShowS)
-> Show (Block inline)
forall inline. Show inline => Int -> Block inline -> ShowS
forall inline. Show inline => [Block inline] -> ShowS
forall inline. Show inline => Block inline -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block inline] -> ShowS
$cshowList :: forall inline. Show inline => [Block inline] -> ShowS
show :: Block inline -> String
$cshow :: forall inline. Show inline => Block inline -> String
showsPrec :: Int -> Block inline -> ShowS
$cshowsPrec :: forall inline. Show inline => Int -> Block inline -> ShowS
Show, Block inline -> Block inline -> Bool
(Block inline -> Block inline -> Bool)
-> (Block inline -> Block inline -> Bool) -> Eq (Block inline)
forall inline. Eq inline => Block inline -> Block inline -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block inline -> Block inline -> Bool
$c/= :: forall inline. Eq inline => Block inline -> Block inline -> Bool
== :: Block inline -> Block inline -> Bool
$c== :: forall inline. Eq inline => Block inline -> Block inline -> Bool
Eq)

instance Functor Block where
    fmap :: (a -> b) -> Block a -> Block b
fmap a -> b
f (BlockPara a
i) = b -> Block b
forall inline. inline -> Block inline
BlockPara (a -> b
f a
i)
    fmap a -> b
f (BlockList ListType
lt (Left a
i)) = ListType -> Either b [Block b] -> Block b
forall inline.
ListType -> Either inline [Block inline] -> Block inline
BlockList ListType
lt (Either b [Block b] -> Block b) -> Either b [Block b] -> Block b
forall a b. (a -> b) -> a -> b
$ b -> Either b [Block b]
forall a b. a -> Either a b
Left (b -> Either b [Block b]) -> b -> Either b [Block b]
forall a b. (a -> b) -> a -> b
$ a -> b
f a
i
    fmap a -> b
f (BlockList ListType
lt (Right [Block a]
bs)) = ListType -> Either b [Block b] -> Block b
forall inline.
ListType -> Either inline [Block inline] -> Block inline
BlockList ListType
lt (Either b [Block b] -> Block b) -> Either b [Block b] -> Block b
forall a b. (a -> b) -> a -> b
$ [Block b] -> Either b [Block b]
forall a b. b -> Either a b
Right ([Block b] -> Either b [Block b])
-> [Block b] -> Either b [Block b]
forall a b. (a -> b) -> a -> b
$ (Block a -> Block b) -> [Block a] -> [Block b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Block a -> Block b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Block a]
bs
    fmap a -> b
_ (BlockCode Maybe Text
a Text
b) = Maybe Text -> Text -> Block b
forall inline. Maybe Text -> Text -> Block inline
BlockCode Maybe Text
a Text
b
    fmap a -> b
f (BlockQuote [Block a]
bs) = [Block b] -> Block b
forall inline. [Block inline] -> Block inline
BlockQuote ([Block b] -> Block b) -> [Block b] -> Block b
forall a b. (a -> b) -> a -> b
$ (Block a -> Block b) -> [Block a] -> [Block b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Block a -> Block b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Block a]
bs
    fmap a -> b
_ (BlockHtml Text
t) = Text -> Block b
forall inline. Text -> Block inline
BlockHtml Text
t
    fmap a -> b
_ Block a
BlockRule = Block b
forall inline. Block inline
BlockRule
    fmap a -> b
f (BlockHeading Int
level a
i) = Int -> b -> Block b
forall inline. Int -> inline -> Block inline
BlockHeading Int
level (a -> b
f a
i)
    fmap a -> b
_ (BlockReference Text
x Text
y) = Text -> Text -> Block b
forall inline. Text -> Text -> Block inline
BlockReference Text
x Text
y
    fmap a -> b
f (BlockPlainText a
x) = b -> Block b
forall inline. inline -> Block inline
BlockPlainText (a -> b
f a
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 (Int -> Inline -> ShowS
[Inline] -> ShowS
Inline -> String
(Int -> Inline -> ShowS)
-> (Inline -> String) -> ([Inline] -> ShowS) -> Show Inline
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Inline] -> ShowS
$cshowList :: [Inline] -> ShowS
show :: Inline -> String
$cshow :: Inline -> String
showsPrec :: Int -> Inline -> ShowS
$cshowsPrec :: Int -> Inline -> ShowS
Show, Inline -> Inline -> Bool
(Inline -> Inline -> Bool)
-> (Inline -> Inline -> Bool) -> Eq Inline
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Inline -> Inline -> Bool
$c/= :: Inline -> Inline -> Bool
== :: Inline -> Inline -> Bool
$c== :: Inline -> Inline -> Bool
Eq)