-
Notifications
You must be signed in to change notification settings - Fork 77
/
Copy pathSubfigures.hs
218 lines (202 loc) · 8.72 KB
/
Subfigures.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
{-
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.
-}
{-# LANGUAGE Rank2Types, OverloadedStrings, FlexibleContexts, LambdaCase #-}
module Text.Pandoc.CrossRef.References.Blocks.Subfigures where
import Control.Monad.Reader
import Control.Monad.State hiding (get, modify)
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 Text.Pandoc.Walk (walk)
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
runSubfigures :: Attr -> [Block] -> [Inline] -> WS (ReplacedResult Block)
runSubfigures (label, cls, attrs) images caption = do
opts <- ask
idxStr <- replaceAttr (Right label) attrs caption SPfxImg
let (cont, st) = flip runState def
$ flip runReaderT opts'
$ runWS
$ runReplace (mkRR replaceSubfigs `extRR` doFigure) images
doFigure :: Block -> WS (ReplacedResult Block)
doFigure (Figure attr caption' content) = runFigure True attr caption' content
doFigure _ = noReplaceRecurse
opts' = opts
{ figureTemplate = subfigureChildTemplate opts
, customLabel = \r i -> customLabel opts ("sub"<>r) i
}
collectedCaptions = B.toList $
intercalate' (B.fromList $ ccsDelim opts)
$ map (B.fromList . collectCaps . snd)
$ sortOn (refIndex . snd)
$ filter (not . null . refTitle . snd)
$ M.toList
$ st ^. 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
lastRef <- fromJust . M.lookup label <$> use (refsAt PfxImg)
let mangledSubfigures = mangleSubfigure <$> st ^. refsAt PfxImg
mangleSubfigure v = v{refIndex = refIndex lastRef, refSubfigure = Just $ refIndex v}
refsAt PfxImg %= (<> mangledSubfigures)
case outFormat opts of
f | isLatexFormat f ->
replaceNoRecurse $ Div nullAttr $
[ RawBlock (Format "latex") "\\begin{pandoccrossrefsubfigures}" ]
<> cont <>
[ Para [RawInline (Format "latex") "\\caption["
, Span nullAttr (removeFootnotes caption)
, RawInline (Format "latex") "]"
, Span nullAttr caption]
, RawBlock (Format "latex") $ mkLaTeXLabel label
, RawBlock (Format "latex") "\\end{pandoccrossrefsubfigures}"]
_ -> replaceNoRecurse
$ Figure (label, "subfigures":cls, setLabel opts idxStr attrs) (Caption Nothing [Para capt])
$ toTable opts cont
where
removeFootnotes = walk removeFootnote
removeFootnote Note{} = Str ""
removeFootnote x = x
toTable :: Options -> [Block] -> [Block]
toTable opts blks
| isLatexFormat $ outFormat opts = concatMap imagesToFigures blks
| subfigGrid opts = [simpleTable align (map ColWidth widths) (map (fmap pure . blkToRow) blks)]
| otherwise = blks
where
align | b:_ <- blks = let ils = blocksToInlines [b] in replicate (length $ mapMaybe getWidth ils) AlignCenter
| otherwise = error "Misformatted subfigures block"
widths | b:_ <- blks = let ils = blocksToInlines [b] in fixZeros $ mapMaybe getWidth ils
| otherwise = error "Misformatted subfigures block"
getWidth (Image (_id, _class, as) _ _)
= Just $ maybe 0 percToDouble $ lookup "width" as
getWidth _ = Nothing
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
percToDouble :: T.Text -> Double
percToDouble percs
| Right (perc, "%") <- T.double percs
= perc/100.0
| otherwise = error "Only percent allowed in subfigure width!"
blkToRow :: Block -> [Block]
blkToRow (Para inls) = mapMaybe inlToCell inls
blkToRow x = [x]
inlToCell :: Inline -> Maybe Block
inlToCell (Image (id', cs, as) txt tgt) = Just $
Figure (id', cs, []) (Caption Nothing [Para txt]) [Plain [Image ("", cs, setW as) txt tgt]]
inlToCell _ = Nothing
setW as = ("width", "100%"):filter ((/="width") . fst) as
replaceSubfigs :: [Inline] -> WS (ReplacedResult [Inline])
replaceSubfigs = (replaceNoRecurse . concat) <=< mapM replaceSubfig
imagesToFigures :: Block -> [Block]
imagesToFigures = \case
x@Figure{} -> [x]
Para xs -> mapMaybe imageToFigure xs
Plain xs -> mapMaybe imageToFigure xs
_ -> []
imageToFigure :: Inline -> Maybe Block
imageToFigure = \case
Image (label,cls,attrs) alt tgt -> Just $
Figure (label, cls, []) (Caption Nothing [Para alt])
[Plain [Image ("",cls,attrs) alt tgt]]
_ -> Nothing
replaceSubfig :: Inline -> WS [Inline]
replaceSubfig x@(Image (label,cls,attrs) alt tgt) = do
opts <- ask
let label' = normalizeLabel label
idxStr <- replaceAttr label' attrs alt SPfxImg
let alt' = applyTemplate idxStr alt $ figureTemplate opts
case outFormat opts of
f | isLatexFormat f -> pure $ latexSubFigure x label
_ -> pure [Image (label, cls, setLabel opts idxStr attrs) alt' tgt]
replaceSubfig x = pure [x]
latexSubFigure :: Inline -> T.Text -> [Inline]
latexSubFigure (Image (_, cls, attrs) alt (src, title)) label =
let
title' = fromMaybe title $ T.stripPrefix "fig:" title
texlabel | T.null label = []
| otherwise = [RawInline (Format "latex") $ mkLaTeXLabel label]
texalt | "nocaption" `elem` cls = []
| otherwise = concat
[ [ RawInline (Format "latex") "["]
, alt
, [ RawInline (Format "latex") "]"]
]
img = Image (label, cls, attrs) alt (src, title')
in concat [
[ RawInline (Format "latex") "\\subfloat" ]
, texalt
, [Span nullAttr $ img:texlabel]
]
latexSubFigure x _ = [x]
normalizeLabel :: T.Text -> Either T.Text T.Text
normalizeLabel label
| "fig:" `T.isPrefixOf` label = Right label
| T.null label = Left "fig"
| otherwise = Right $ "fig:" <> 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 xs = Cell nullAttr AlignDefault (RowSpan 1) (ColSpan 1) xs
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 <- ask
let label' = normalizeLabel label
let title = blocksToInlines [btitle]
attrs = case blocksToInlines content of
[Image (_, _, as) _ _] -> fattrs <> as
_ -> fattrs
idxStr <- replaceAttr label' attrs title SPfxImg
let title' = case outFormat opts of
f | isLatexFormat f -> title
_ -> applyTemplate idxStr title $ figureTemplate opts
caption' = Caption short (walkReplaceInlines title' title btitle:rest)
replaceNoRecurse $
if subFigure && isLatexFormat (outFormat opts)
then Plain $ latexSubFigure (head $ blocksToInlines content) label
else Figure (label,cls,setLabel opts idxStr fattrs) caption' content
runFigure _ _ _ _ = noReplaceNoRecurse