{-# LANGUAGE ViewPatterns, PatternGuards, PatternSynonyms #-}

#if MIN_VERSION_pandoc_types(1,20,0)
{-# LANGUAGE OverloadedStrings #-}
#endif

import           Text.Pandoc.JSON
import           Text.Pandoc.Walk (walk)
import           Text.Pandoc.Options (def)
import           Text.Pandoc.Shared (stringify)
import qualified Data.Map as M
#if !MIN_VERSION_pandoc_types(1,20,0)
import           Data.List.Extra (replace)
#endif

#if MIN_VERSION_pandoc(2,0,0)
import           Text.Pandoc.Writers (Writer (..), getWriter)
import           Text.Pandoc.Class (runPure)
import qualified Data.ByteString.Lazy.Char8 as C8L
import qualified Data.Text as T
import           Control.Exception (displayException)
#else
import           Text.Pandoc (Writer (..), getWriter)
#endif

#if MIN_VERSION_pandoc(2,8,0)
import           Text.Pandoc.Class (PandocPure)
import           Text.Pandoc.Error (PandocError)
#endif

#if MIN_VERSION_pandoc_types(1,20,0)
type STRING = T.Text
rEPLACE :: STRING -> STRING -> STRING -> STRING
rEPLACE = T.replace
tOSTRING :: T.Text -> String
tOSTRING = T.unpack
fROMSTRING :: String -> T.Text
fROMSTRING = T.pack
tOTEXT :: T.Text -> T.Text
tOTEXT = id
#else
type STRING = String
rEPLACE :: STRING -> STRING -> STRING -> STRING
rEPLACE = replace
tOSTRING :: String -> String
tOSTRING = id
fROMSTRING :: String -> String
fROMSTRING = id
tOTEXT :: T.Text -> String
tOTEXT = T.unpack
#endif

#if MIN_VERSION_pandoc(2,8,0)
rUNGETWRITER :: PandocPure a -> Either PandocError a
rUNGETWRITER = runPure
#else
rUNGETWRITER :: a -> a
rUNGETWRITER = id
#endif

#if MIN_TOOL_VERSION_ghc(7,10,1)
pattern Style :: STRING -> Inline
#endif
pattern Style x <- Math InlineMath x

#if MIN_TOOL_VERSION_ghc(7,10,1)
pattern Subst :: STRING -> Inline
#endif
pattern Subst x = Math InlineMath x

#if MIN_TOOL_VERSION_ghc(7,10,1)
pattern SubstVerbatim :: STRING -> Inline
#endif
pattern SubstVerbatim x <- Math DisplayMath x

#if MIN_TOOL_VERSION_ghc(7,10,1)
pattern Alt :: [Inline] -> [Inline]
#endif
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

styleFromMeta :: Maybe Format -> Pandoc -> IO Pandoc
styleFromMeta (Just fm) (Pandoc m bs) = do
    let b = unMeta m
    return $ Pandoc m $
        walk (substInlineStyle fm b) $  -- apply styles for links and images
        walk (substBlockStyle fm b) bs  -- apply para_style to paragraphs
styleFromMeta _ p = return p

substBlockStyle :: Format -> MMap -> Block -> Block
substBlockStyle _ _ b@(Para is@(Image {} : _))
    | all isImage is = b    -- do not apply para_style to standalone images
    where isImage Image {} = True
          isImage _        = False
substBlockStyle (Format fmt) m b@(Para cnt)
    | Just (MetaMap mm) <- M.lookup "para_style" m
    , Just (MetaBlocks [p]) <- M.lookup fmt mm =
        case p of
            Para  [Span attr _] -> Plain [Span attr cnt]
            Plain [Span attr _] -> Plain [Span attr cnt]
            _                   -> b
substBlockStyle _ _ b = 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 params = (alt, tgt)
            substPlainParams = Span nullAttr . map (substParams fm params)
            substInlineStyle' (Just (MetaBlocks [CodeBlock _ vb])) =
                RawInline fm $ substParamsInRawBlock fm params vb
            substInlineStyle' (Just (MetaBlocks mbs)) =
                RawInline fm $ renderInlines fm $ map substInlineStyle'' mbs
                    where substInlineStyle'' mb =
                            case mb of
                                Plain is       -> substPlainParams is
                                Para is        -> substPlainParams is
                                d@Div {}       ->
                                    RawInline fm $
                                        substParamsInRawBlock fm params $
                                            renderBlocks fm [d]
                                RawBlock bfm b ->
                                    RawInline bfm $
                                        substParamsInRawBlock bfm params b
                                _              -> 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 -> Inline -> Inline
substParams _  (alt, _)        (Subst "ALT")           = Span nullAttr alt
substParams fm params          (SubstVerbatim "ALT")   = RawInline fm $
    stringify $ substParams fm params $ Subst "ALT"
substParams _  (_, (src, _))   (Subst "SRC")           = Str src
substParams fm (_, (src, _))   (SubstVerbatim "SRC")   = RawInline fm src
substParams _  (_, (_, title)) (Subst "TITLE")         = Str title
substParams fm (_, (_, title)) (SubstVerbatim "TITLE") = RawInline fm title
substParams _  params          (RawInline fm s)        = RawInline fm $
    substParamsInRawBlock fm params s
substParams _  _               i                       = i

substParamsInRawBlock :: Format -> PureInlineParams -> STRING -> STRING
substParamsInRawBlock fm (alt, (src, title)) s =
    foldr (\(p, is) -> rEPLACE p $ renderInlines fm is) s
          [("$ALT$",     alt                                           )
          ,("$SRC$",     [Str src]                                     )
          ,("$TITLE$",   [Str title]                                   )
          ,("$$ALT$$",   [RawInline fm $ stringify $ Span nullAttr alt])
          ,("$$SRC$$",   [RawInline fm src]                            )
          ,("$$TITLE$$", [RawInline fm title]                          )
          ]

renderBlocks :: Format -> [Block] -> STRING
renderBlocks fm p =
    let fmt = toWriterFormat fm
        writer = getWriter fmt
        doc = Pandoc (Meta M.empty) p
    in case rUNGETWRITER writer of
        Left _ -> error $ "Unknown format " ++ tOSTRING fmt
#if MIN_VERSION_pandoc(2,0,0)
        Right (TextWriter w, _) ->
            case runPure $ w def doc of
                Left e -> fROMSTRING $ displayException e
                Right r -> tOTEXT r
        Right (ByteStringWriter w, _) ->
            case runPure $ w def doc of
                Left e -> fROMSTRING $ displayException e
                Right r -> fROMSTRING $ C8L.unpack r
#else
        Right (PureStringWriter w) -> w def doc
        _ -> error $ "Unsupported format " ++ tOSTRING fmt ++
            ", use Pandoc 2.0 or newer!"
#endif

renderInlines :: Format -> [Inline] -> STRING
renderInlines fm p = renderBlocks fm [Plain p]

toWriterFormat :: Format -> STRING
toWriterFormat (Format "tex") = "latex"
toWriterFormat (Format fmt)   = fmt

main :: IO ()
main = toJSONFilter styleFromMeta