Subfigures.hs

{-
pandoc-crossref is a pandoc filter for numbering figures,
equations, tables and cross-references to them.
Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-}

module Text.Pandoc.CrossRef.References.Blocks.Subfigures where

import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Read as T
import Text.Pandoc.Definition
import qualified Text.Pandoc.Builder as B
import Data.Default (def)
import Data.List
import Data.Maybe
import Lens.Micro
import Lens.Micro.Mtl
import Text.Pandoc.Shared (blocksToInlines)

import Text.Pandoc.CrossRef.References.Types
import Text.Pandoc.CrossRef.References.Monad
import Text.Pandoc.CrossRef.References.Blocks.Util
import Text.Pandoc.CrossRef.Util.Options
import Text.Pandoc.CrossRef.Util.Template
import Text.Pandoc.CrossRef.Util.Util
import Text.Pandoc.CrossRef.Util.Generic

runSubfigures :: Attr -> [Block] -> [Inline] -> WS (ReplacedResult Block)
runSubfigures (label, cls, attrs) images caption = do
  opts <- use wsOptions
  ref <- replaceAttr (Just label) attrs caption SPfxImg
  idxStr <- chapIndex ref
  glob <- use $ wsReferences . stGlob
  hiddenHdr <- use $ wsReferences . stHiddenHeaderLevel
  let opts' = opts
          { figureTemplate = subfigureChildTemplate opts
          , customLabel = customLabel opts . Sub
          }
  (cont, st) <- embedWS (WState opts' (References def def glob hiddenHdr))
    $ runReplace (mkRR replaceSubfigs) images
  let collectedCaptions = B.toList $
          intercalate' (B.fromList $ ccsDelim opts)
        $ map (B.fromList . collectCaps . snd)
        $ sortOn (refIndex . snd)
        $ filter (not . null . refTitle . snd)
        $ M.toList
        $ st ^. wsReferences . refsAt PfxImg
      collectCaps v =
            applyTemplate
              (chapPrefix (chapDelim opts) (refIndex v))
              (refTitle v)
              (ccsTemplate opts)
      vars = M.fromDistinctAscList
                [ ("ccs", collectedCaptions)
                , ("i", idxStr)
                , ("t", caption)
                ]
      capt = applyTemplate' vars $ subfigureTemplate opts
  let mangledSubfigures = mangleSubfigure <$> st ^. wsReferences . refsAt PfxImg
      mangleSubfigure v = v{refIndex = refIndex ref, refSubfigure = Just $ refIndex v}
  wsReferences . refsAt PfxImg %= (<> mangledSubfigures)
  wsReferences . stGlob .= st ^. wsReferences . stGlob
  -- stHiddenHeaderLevel shouldn't have changed, but for future-proofing...
  wsReferences . stHiddenHeaderLevel .= st ^. wsReferences . stHiddenHeaderLevel
  replaceNoRecurse $ if isLatexFormat opts
    then Div nullAttr $
      [ RawBlock (Format "latex") "\\begin{pandoccrossrefsubfigures}" ]
      <> cont <>
      [ Para $ latexCaption ref
      , RawBlock (Format "latex") "\\end{pandoccrossrefsubfigures}"]
    else Figure (label, "subfigures":cls, setLabel opts idxStr attrs)
                (Caption Nothing [Para capt])
      $ toTable opts cont
  where
    toTable :: Options -> [Block] -> [Block]
    toTable opts blks
      | subfigGrid opts = [simpleTable align (map ColWidth widths') (map (fmap pure . blkToRow) blks)]
      | subfigColumns opts = mapMaybe figurize blks
      | otherwise = blks
      where
        figurize x
          | Para is <- x = case (mapMaybe getImg is) `zip` widths' of
              [] -> Nothing -- skip empty Paras
              [_] -> error "The impossible happened: single-element Para in \
                \subfigure which is not a figure"
              xs -> Just $ Div ("", ["columns"], []) $ map columnize xs
          | otherwise = Just x
        columnize ((id', cs, as, alt, tgt), width) =
          Div ("", ["column"], [("width", T.pack (show (width * 100.0)) <> "%")]) [
            implicitFigure (id', cs, filter ((/="width") . fst) as) alt tgt Figure
          ]
        widths' = widths blks
        align | b:_ <- blks = let ils = blocksToInlines [b] in replicate (length $ mapMaybe getWidth ils) AlignCenter
              | otherwise = error "Misformatted subfigures block"
        blkToRow :: Block -> [Block]
        blkToRow (Para inls) = zipWith inlToCell widths' $ mapMaybe getImg inls
        blkToRow x = [x]
        getImg (Image (id', cs, as) txt tgt) = Just (id', cs, as, txt, tgt)
        getImg _ = Nothing
        inlToCell w (id', cs, as, txt, tgt) = implicitFigure (id', cs, setW w as) txt tgt Figure
        setW w as = ("width", width):filter ((/="width") . fst) as
          where
            -- With docx, since pandoc 3.0, 100% is interpreted as "page width",
            -- even in table cells. Hence, this hack.
            width
              | isDocxFormat opts = T.pack (show $ w * 100) <> "%"
              | otherwise = "100%"

getWidth :: Inline -> Maybe Double
getWidth (Image (_id, _class, as) _ _)
  = Just $ maybe 0 percToDouble $ lookup "width" as
  where
    percToDouble :: T.Text -> Double
    percToDouble percs
      | Right (perc, "%") <- T.double percs
      = perc/100.0
      | otherwise = error "Only percent allowed in subfigure width!"
getWidth _ = Nothing

widths :: [Block] -> [Double]
widths (b:_) = let ils = blocksToInlines [b] in fixZeros $ mapMaybe getWidth ils
  where
    fixZeros :: [Double] -> [Double]
    fixZeros ws
      = let nz = length $ filter (== 0) ws
            rzw = (0.99 - sum ws) / fromIntegral nz
        in if nz>0
            then map (\x -> if x == 0 then rzw else x) ws
            else ws
widths _ = error "Misformatted subfigures block"

replaceSubfigs :: Block -> WS (ReplacedResult Block)
replaceSubfigs (Figure attr caption' content) = runFigure True attr caption' content
-- this triggers when implicit_figures is disabled
replaceSubfigs (Para [Image attr caption' tgt]) =
  implicitFigure attr caption' tgt $ runFigure True
replaceSubfigs blk@(Para images) =
  let go _ [] = pure []
      go (w:ws) (x@Image{}:xs) = liftA2 (:) (replaceSubfig w x) (go ws xs)
      go ws (x:xs) = ([x] :) <$> go ws xs
  in replaceNoRecurse . Para . concat =<< go (widths [blk]) images
replaceSubfigs _ = noReplaceRecurse

-- this is mostly copy-paste from pandoc markdown reader
implicitFigure :: Attr -> [Inline] -> (T.Text, T.Text) -> (Attr -> Caption -> [Block] -> a) -> a
implicitFigure (ident, classes, attribs) capt' (url, title) f =
  let alt = maybe capt B.text $ lookup "alt" attribs
      capt = B.fromList capt'
      attribs' = filter (liftA2 (&&) (/= "latex-placement") (/= "alt") . fst) attribs
      figattribs = filter ((=="latex-placement") . fst) attribs
      figattr = (ident, mempty, figattribs)
      caption = B.simpleCaption $ B.plain capt
      figbody = B.plain $ B.imageWith ("", classes, attribs') url title alt
  in f figattr caption (B.toList figbody)

replaceSubfigs' :: [(Double, Inline)] -> WS [Inline]
replaceSubfigs' = fmap concat . mapM (uncurry replaceSubfig)

replaceSubfig :: Double -> Inline -> WS [Inline]
replaceSubfig width x@(Image (label,cls,attrs) alt tgt) = do
  opts <- use wsOptions
  ref <- replaceAttr (normalizeLabel label) attrs alt SPfxImg
  idxStr <- chapIndex ref
  let alt' = applyTemplate idxStr alt $ figureTemplate opts
  pure $ if isLatexFormat opts
    then latexSubFigure width x ref
    else [Image (fromMaybe "" (refLabel ref), cls, setLabel opts idxStr attrs) alt' tgt]
replaceSubfig _ _ = pure []

latexSubFigure :: Double -> Inline -> RefRec -> [Inline]
latexSubFigure width (Image (_, cls, attrs) alt (src, title)) ref =
  let
    title' = fromMaybe title $ T.stripPrefix "fig:" title
    texalt | "nocaption" `elem` cls  = []
           | otherwise = concat
              [ [ RawInline (Format "latex") "\\caption{"]
              , alt
              , latexLabel ref
              , [ RawInline (Format "latex") "}"]
              ]
    filterWidth = filter $ (/= "width") . fst
    img = Image (fromMaybe "" (refLabel ref), cls, filterWidth attrs) alt (src, title')
  in concat [
      [ RawInline (Format "latex") ("\\begin{subfigure}{" <> T.pack (show width) <> "\\linewidth}")
      , RawInline (Format "latex") "\\centering"
      , img
      ]
      , texalt
      , [RawInline (Format "latex") "\\end{subfigure}%\n"]
      ]
latexSubFigure _ x _ = [x]

normalizeLabel :: T.Text -> Maybe T.Text
normalizeLabel label
  | T.null label = Nothing
  | otherwise  = Just label

simpleTable :: [Alignment] -> [ColWidth] -> [[[Block]]] -> Block
simpleTable align width bod = Table nullAttr noCaption (zip align width)
  noTableHead [mkBody bod] noTableFoot
  where
  mkBody xs = TableBody nullAttr (RowHeadColumns 0) [] (map mkRow xs)
  mkRow xs = Row nullAttr (map mkCell xs)
  mkCell = Cell nullAttr AlignDefault (RowSpan 1) (ColSpan 1)
  noCaption = Caption Nothing mempty
  noTableHead = TableHead nullAttr []
  noTableFoot = TableFoot nullAttr []

runFigure :: Bool -> Attr -> Caption -> [Block] -> WS (ReplacedResult Block)
runFigure subFigure (label, cls, fattrs) (Caption short (btitle : rest)) content = do
  opts <- use wsOptions
  let label' = normalizeLabel label
  let title = blocksToInlines [btitle]
      (attrs, content') = case blocksToInlines content of
        [Image attr@(_, _, as) _ tgt] ->
            -- the second argument is a fix for
            -- https://github.com/jgm/pandoc/issues/9720
            (fattrs <> as, \capt -> [Plain [Image attr capt tgt]])
        _ -> (fattrs, const content)
  ref <- replaceAttr label' attrs title SPfxImg
  idxStr <- chapIndex ref
  let listHidden = refHideFromList ref
  let short' | listHidden = Just mempty
             | otherwise = short
  let title'
        | isLatexFormat opts = title
        | otherwise = applyTemplate idxStr title $ figureTemplate opts
      caption' = Caption short' (walkReplaceInlines title' title btitle:rest)
  replaceNoRecurse $
    if subFigure && isLatexFormat opts
    then Plain $ case blocksToInlines content of
      ctHead:_ -> latexSubFigure 1.0 ctHead ref
      _ -> error "The impossible happened: empty content in subfigures"
    else Figure (label,cls,setLabel opts idxStr fattrs) caption' (content' title')
runFigure _ _ _ _ = noReplaceRecurse