{-# OPTIONS_HADDOCK prune, ignore-exports #-}
{-# LANGUAGE ViewPatterns, PatternGuards, PatternSynonyms #-}

import           Text.Pandoc.JSON
import           Text.Pandoc.Walk (walk)
import           Text.Pandoc.Shared (stringify)
import           Text.Pandoc.XML (escapeStringForXML)
import qualified Data.Map as M
import           Data.String.Utils (replace)
import           Text.LaTeX.Base.Syntax (protectString)

#if MIN_VERSION_pandoc(2,0,0)
#define MBPLAIN Plain
#else
#define MBPLAIN Para
#endif

pattern Style x <- Math InlineMath x
pattern Alt x <- (dropWhile (== Space) -> x)

type MMap = M.Map String MetaValue
type PureInlineParams = ([Inline], Target)          -- style:(alt, target)
type InlineParams = (Inline, [Inline], Target)      -- (style:alt, target)
type InlineCons = [Inline] -> Target -> Inline      -- Image or Link

-- | Applies style found in the metadata of the document for various objects
--
-- Styling is supported for following types of objects:
--
--  * Standalone images
--
--  * Inline images
--
--  * Links
--
--  * Paragraphs (with restrictions, see below)
--
-- Styles are read from the metadata of the document: they may reside inside
-- the document or in a separate YAML file. For example
--
-- > ---
-- > img_style :
-- >   html : |
-- >     <div style="clear: both; text-align: center; margin-bottom: 16px">
-- >     <a href="$SRC$" style="margin-left: 10em;" alt="$ALT$">
-- >     <img border="0" src="$SRC$" /></a></div>
-- >   latex : |
-- >     \begin{center}
-- >     \includegraphics{$SRC$}
-- >     \end{center}
-- > link_style :
-- >   html : |
-- >     <a href="$SRC$" style="margin-left: 1em; margin-right: 1em;">$ALT$</a>
-- >   latex : |
-- >     \href{$SRC$}{\colorbox{green}{$ALT$}}
-- > para_style :
-- >   html : |
-- >     <span style="display: block; margin-bottom: 16px;"></span>
-- > ...
--
-- declares styles /img_style/, /link_style/ and /para_style/. Their names
-- (except for the last) are arbitrarily chosen and may be referred from the
-- document, for example
--
-- > ![$img_style$](../images/an_image.png)
-- > [$link_style$ *here*](http://example.com/)
--
-- Placeholders /$ALT$/, /$SRC$/ and /$TITLE$/ from style declarations are
-- to be replaced by concrete data found in the object declaration. In the
-- last example @*here*@ corresponds to /$ALT$/ and @http:\/\/example.com/@
-- corresponds to /$SRC$/.
--
-- As soon as paragraphs do not have place where to put extra data, style
-- /para_style/ is applied to all paragraphs in the document. Currently only
-- transformation to a span block is supported. Any contents found between
-- opening and closing span tags are ignored: actual paragraph contents will
-- be inserted inside them.
--
styleFromMeta :: Maybe Format -> Pandoc -> IO Pandoc
styleFromMeta (Just fm) (Pandoc m bs) =
    return $ Pandoc m $ walk (substStyle fm $ unMeta m) bs
styleFromMeta _ p = return p

substStyle :: Format -> MMap -> Block -> Block
substStyle fm@(Format fmt) m b@(Para [Image attr (Style style : Alt alt) tgt])
    | Just (MetaMap mm) <- M.lookup style m =
        let params = (alt, tgt)
            substStyle' (Just (MetaBlocks [RawBlock f s])) =
                RawBlock f $ substParams fm params s
            substStyle' (Just (MetaBlocks [b])) = walk substParams' b
                where substParams' (RawInline f s) =
                            RawInline f $ substParams fm params s
                      substParams' i = i
            substStyle' Nothing = Para [Image attr alt tgt]
            substStyle' _ = b
        in substStyle' $ M.lookup fmt mm
    | otherwise = b
substStyle fm@(Format fmt) m (Para cnt)
    | Just (MetaMap mm) <- M.lookup "para_style" m
    , Just (MetaBlocks [MBPLAIN [Span attr _]]) <- M.lookup fmt mm =
        walk (substInlineStyle fm m) $ Plain [Span attr cnt]
substStyle fm m b = walk (substInlineStyle fm m) b

substInlineStyle :: Format -> MMap -> Inline -> Inline
substInlineStyle fm@(Format fmt) m
                 i@(toInlineParams -> Just ((Style style, alt, tgt), cons))
    | Just (MetaMap mm) <- M.lookup style m =
        let substInlineStyle' (Just (MetaBlocks
                                        [MBPLAIN (RawInline f s : r)])) =
                RawInline f $ substParams fm params $
                                s ++ stringify' fm (map subst r)
                where params = (alt, tgt)
                      subst (Style "ALT") = RawInline f "$ALT$"
                      subst i = i
            substInlineStyle' Nothing = cons alt tgt
            substInlineStyle' _ = i
        in substInlineStyle' $ M.lookup fmt mm
substInlineStyle _ _ i = i

toInlineParams :: Inline -> Maybe (InlineParams, InlineCons)
toInlineParams (Image attr (style@(Style _) : Alt alt) tgt) =
    Just ((style, alt, tgt), Image attr)
toInlineParams (Link attr (style@(Style _) : Alt alt) tgt) =
    Just ((style, alt, tgt), Link attr)
toInlineParams _ = Nothing

substParams :: Format -> PureInlineParams -> String -> String
substParams fm (alt, (escape fm -> src, escape fm -> title)) s =
    foldr (uncurry replace) s
          [("$ALT$", stringify' fm alt), ("$SRC$", src), ("$TITLE$", title)]

escape :: Format -> String -> String
escape (Format "latex") = protectString
escape (Format "html") = escapeStringForXML
-- TODO: properly escape other formats
escape _ = id

stringify' :: Format -> [Inline] -> String
stringify' fm@(Format fmt@("latex")) =
    foldr ((++) . subst) ""
    where subst (Emph x) = "\\emph{" ++ stringify' fm x ++ "}"
          subst (Strong x) = "\\textbf{" ++ stringify' fm x ++ "}"
          subst (Strikeout x) = "\\sout{" ++ stringify' fm x ++ "}"
          subst (Superscript x) = "\\textsuperscript{" ++ stringify' fm x ++ "}"
          subst (Subscript x) = "\\textsubscript{" ++ stringify' fm x ++ "}"
          subst (RawInline fmt x) = x
          subst (Math _ x) = "$" ++ x ++ "$"
          subst (Str x) = escape fm x
          subst x = stringify x
stringify' fm@(Format fmt@("html")) =
    foldr ((++) . subst) ""
    where subst (Emph x) = "<em>" ++ stringify' fm x ++ "</em>"
          subst (Strong x) = "<strong>" ++ stringify' fm x ++ "</strong>"
          subst (Strikeout x) = "<del>" ++ stringify' fm x ++ "</del>"
          subst (Superscript x) = "<sup>" ++ stringify' fm x ++ "</sup>"
          subst (Subscript x) = "<sub>" ++ stringify' fm x ++ "</sub>"
          subst (RawInline fmt x) = x
          subst (Str x) = escape fm x
          subst x = stringify x
-- TODO: properly stringify' other formats
stringify' _ = stringify

main :: IO ()
main = toJSONFilter styleFromMeta