Merge pull request #2570 from mb21/rst-reader-imgattrs

Image attributes

7 files changed, 94 insertions, 50 deletions

diff --git a/src/Text/Pandoc/CSS.hs b/src/Text/Pandoc/CSS.hs
index 2287a5958..f479ed9d0 100644
--- a/src/Text/Pandoc/CSS.hs
+++ b/src/Text/Pandoc/CSS.hs
@@ -1,5 +1,6 @@
-module Text.Pandoc.CSS ( foldOrElse,
-                         pickStyleAttrProps
+module Text.Pandoc.CSS ( foldOrElse
+                       , pickStyleAttrProps
+                       , pickStylesToKVs
                        )
 where
 
@@ -26,6 +27,16 @@ eitherToMaybe :: Either a b -> Maybe b
 eitherToMaybe (Right x) = Just x
 eitherToMaybe _ = Nothing
 
+-- | takes a list of keys/properties and a CSS string and
+-- returns the corresponding key-value-pairs.
+pickStylesToKVs :: [String] -> String -> [(String, String)]
+pickStylesToKVs props styleAttr =
+  case parse styleAttrParser "" styleAttr of
+    Left _ -> []
+    Right styles -> filter (\s -> fst s `elem` props) styles
+
+-- | takes a list of key/property synonyms and a CSS string and maybe
+-- returns the value of the first match (in order of the supplied list)
 pickStyleAttrProps :: [String] -> String -> Maybe String
 pickStyleAttrProps lookupProps styleAttr = do
     styles <- eitherToMaybe $ parse styleAttrParser "" styleAttr
diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs
index 3e934d272..44f67ce75 100644
--- a/src/Text/Pandoc/Readers/Docx.hs
+++ b/src/Text/Pandoc/Readers/Docx.hs
@@ -298,10 +298,17 @@ runToInlines (Footnote bps) = do
 runToInlines (Endnote bps) = do
   blksList <- concatReduce <$> (mapM bodyPartToBlocks bps)
   return $ note blksList
-runToInlines (InlineDrawing fp bs) = do
+runToInlines (InlineDrawing fp bs ext) = do
   mediaBag <- gets docxMediaBag
   modify $ \s -> s { docxMediaBag = insertMedia fp Nothing bs mediaBag }
-  return $ image fp "" ""
+  return $ imageWith (extentToAttr ext) fp "" ""
+
+extentToAttr :: Extent -> Attr
+extentToAttr (Just (w, h)) =
+  ("", [], [("width", showDim w), ("height", showDim h)] )
+  where
+    showDim d = show (d / 914400) ++ "in"
+extentToAttr _ = nullAttr
 
 parPartToInlines :: ParPart -> DocxContext Inlines
 parPartToInlines (PlainRun r) = runToInlines r
@@ -348,10 +355,10 @@ parPartToInlines (BookMark _ anchor) =
     unless inHdrBool
       (modify $ \s -> s { docxAnchorMap = M.insert anchor newAnchor anchorMap})
     return $ spanWith (newAnchor, ["anchor"], []) mempty
-parPartToInlines (Drawing fp bs) = do
+parPartToInlines (Drawing fp bs ext) = do
   mediaBag <- gets docxMediaBag
   modify $ \s -> s { docxMediaBag = insertMedia fp Nothing bs mediaBag }
-  return $ image fp "" ""
+  return $ imageWith (extentToAttr ext) fp "" ""
 parPartToInlines (InternalHyperLink anchor runs) = do
   ils <- concatReduce <$> mapM runToInlines runs
   return $ link ('#' : anchor) "" ils
diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs
index 91655d2b4..eec8b12c9 100644
--- a/src/Text/Pandoc/Readers/Docx/Parse.hs
+++ b/src/Text/Pandoc/Readers/Docx/Parse.hs
@@ -35,6 +35,7 @@ module Text.Pandoc.Readers.Docx.Parse ( Docx(..)
                                       , Body(..)
                                       , BodyPart(..)
                                       , TblLook(..)
+                                      , Extent
                                       , ParPart(..)
                                       , Run(..)
                                       , RunElem(..)
@@ -62,6 +63,7 @@ import Control.Monad.Reader
 import Control.Applicative ((<|>))
 import qualified Data.Map as M
 import Text.Pandoc.Compat.Except
+import Text.Pandoc.Shared (safeRead)
 import Text.TeXMath.Readers.OMML (readOMML)
 import Text.Pandoc.Readers.Docx.Fonts (getUnicode, Font(..))
 import Text.TeXMath (Exp)
@@ -196,20 +198,23 @@ data Row = Row [Cell]
 data Cell = Cell [BodyPart]
             deriving Show
 
+-- (width, height) in EMUs
+type Extent = Maybe (Double, Double)
+
 data ParPart = PlainRun Run
              | Insertion ChangeId Author ChangeDate [Run]
              | Deletion ChangeId Author ChangeDate [Run]
              | BookMark BookMarkId Anchor
              | InternalHyperLink Anchor [Run]
              | ExternalHyperLink URL [Run]
-             | Drawing FilePath B.ByteString
+             | Drawing FilePath B.ByteString Extent
              | PlainOMath [Exp]
              deriving Show
 
 data Run = Run RunStyle [RunElem]
          | Footnote [BodyPart]
          | Endnote [BodyPart]
-         | InlineDrawing FilePath B.ByteString
+         | InlineDrawing FilePath B.ByteString Extent
            deriving Show
 
 data RunElem = TextRun String | LnBrk | Tab | SoftHyphen | NoBreakHyphen
@@ -619,13 +624,13 @@ expandDrawingId s = do
 elemToParPart :: NameSpaces -> Element -> D ParPart
 elemToParPart ns element
   | isElem ns "w" "r" element
-  , Just _ <- findChild (elemName ns "w" "drawing") element =
+  , Just drawingElem <- findChild (elemName ns "w" "drawing") element =
     let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
         drawing = findElement (QName "blip" (Just a_ns) (Just "a")) element
                   >>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
     in
      case drawing of
-       Just s -> expandDrawingId s >>= (\(fp, bs) -> return $ Drawing fp bs)
+       Just s -> expandDrawingId s >>= (\(fp, bs) -> return $ Drawing fp bs $ elemToExtent drawingElem)
        Nothing -> throwError WrongElem
 -- The below is an attempt to deal with images in deprecated vml format.
 elemToParPart ns element
@@ -635,7 +640,7 @@ elemToParPart ns element
                   >>= findAttr (elemName ns "r" "id")
     in
      case drawing of
-       Just s -> expandDrawingId s >>= (\(fp, bs) -> return $ Drawing fp bs)
+       Just s -> expandDrawingId s >>= (\(fp, bs) -> return $ Drawing fp bs Nothing)
        Nothing -> throwError WrongElem
 elemToParPart ns element
   | isElem ns "w" "r" element =
@@ -687,6 +692,16 @@ lookupFootnote s (Notes _ fns _) = fns >>= (M.lookup s)
 lookupEndnote :: String -> Notes -> Maybe Element
 lookupEndnote s (Notes _ _ ens) = ens >>= (M.lookup s)
 
+elemToExtent :: Element -> Extent
+elemToExtent drawingElem =
+  case (getDim "cx", getDim "cy") of
+    (Just w, Just h) -> Just (w, h)
+    _ -> Nothing
+    where
+      wp_ns  = "http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing"
+      getDim at = findElement (QName "extent" (Just wp_ns) (Just "wp")) drawingElem
+                    >>= findAttr (QName at Nothing Nothing) >>= safeRead
+
 elemToRun :: NameSpaces -> Element -> D Run
 elemToRun ns element
   | isElem ns "w" "r" element
@@ -697,7 +712,7 @@ elemToRun ns element
     in
      case drawing of
        Just s -> expandDrawingId s >>=
-                 (\(fp, bs) -> return $ InlineDrawing fp bs)
+                 (\(fp, bs) -> return $ InlineDrawing fp bs $ elemToExtent drawingElem)
        Nothing -> throwError WrongElem
 elemToRun ns element
   | isElem ns "w" "r" element
diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs
index 85f34d9d8..7be0cd392 100644
--- a/src/Text/Pandoc/Readers/RST.hs
+++ b/src/Text/Pandoc/Readers/RST.hs
@@ -541,6 +541,12 @@ directive' = do
   body <- option "" $ try $ blanklines >> indentedBlock
   optional blanklines
   let body' = body ++ "\n\n"
+      imgAttr cl = ("", classes, getAtt "width" ++ getAtt "height")
+        where
+          classes = words $ maybe "" trim $ lookup cl fields
+          getAtt k = case lookup k fields of
+                       Just v  -> [(k, filter (not . isSpace) v)]
+                       Nothing -> []
   case label of
         "raw" -> return $ B.rawBlock (trim top) (stripTrailingNewlines body)
         "role" -> addNewRole top $ map (\(k,v) -> (k, trim v)) fields
@@ -590,15 +596,16 @@ directive' = do
         "figure" -> do
            (caption, legend) <- parseFromString extractCaption body'
            let src = escapeURI $ trim top
-           return $ B.para (B.image src "fig:" caption) <> legend
+           return $ B.para (B.imageWith (imgAttr "figclass") src "fig:" caption) <> legend
         "image" -> do
            let src = escapeURI $ trim top
            let alt = B.str $ maybe "image" trim $ lookup "alt" fields
+           let attr = imgAttr "class"
            return $ B.para
                   $ case lookup "target" fields of
                           Just t  -> B.link (escapeURI $ trim t) ""
-                                     $ B.image src "" alt
-                          Nothing -> B.image src "" alt
+                                     $ B.imageWith attr src "" alt
+                          Nothing -> B.imageWith attr src "" alt
         "class" -> do
             let attrs = ("", (splitBy isSpace $ trim top), map (\(k,v) -> (k, trimr v)) fields)
             --  directive content or the first immediately following element
@@ -812,10 +819,10 @@ substKey = try $ do
   res <- B.toList <$> directive'
   il <- case res of
              -- use alt unless :alt: attribute on image:
-             [Para [Image _ [Str "image"] (src,tit)]] ->
-                return $ B.image src tit alt
-             [Para [Link _ [Image _ [Str "image"] (src,tit)] (src',tit')]] ->
-                return $ B.link src' tit' (B.image src tit alt)
+             [Para [Image attr [Str "image"] (src,tit)]] ->
+                return $ B.imageWith attr src tit alt
+             [Para [Link _ [Image attr [Str "image"] (src,tit)] (src',tit')]] ->
+                return $ B.link src' tit' (B.imageWith attr src tit alt)
              [Para ils] -> return $ B.fromList ils
              _          -> mzero
   let key = toKey $ stripFirstAndLast ref
diff --git a/src/Text/Pandoc/Readers/Textile.hs b/src/Text/Pandoc/Readers/Textile.hs
index 502595e0b..355285f54 100644
--- a/src/Text/Pandoc/Readers/Textile.hs
+++ b/src/Text/Pandoc/Readers/Textile.hs
@@ -537,11 +537,8 @@ image :: Parser [Char] ParserState Inlines
 image = try $ do
   char '!' >> notFollowedBy space
   (ident, cls, kvs) <- attributes
-  let getAtt k styles = case pickStyleAttrProps [k] styles of
-                          Just v  -> [(k, v)]
-                          Nothing -> []
   let attr = case lookup "style" kvs of
-               Just stls -> (ident, cls, getAtt "width" stls ++ getAtt "height" stls)
+               Just stls -> (ident, cls, pickStylesToKVs ["width", "height"] stls)
                Nothing   -> (ident, cls, kvs)
   src <- manyTill anyChar' (lookAhead $ oneOf "!(")
   alt <- option "" (try $ (char '(' >> manyTill anyChar' (char ')')))
diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs
index 6df199fc9..ce4d456a3 100644
--- a/src/Text/Pandoc/Writers/ODT.hs
+++ b/src/Text/Pandoc/Writers/ODT.hs
@@ -40,7 +40,7 @@ import Codec.Archive.Zip
 import Text.Pandoc.Options ( WriterOptions(..), WrapOption(..) )
 import Text.Pandoc.Shared ( stringify, fetchItem', warn,
                             getDefaultReferenceODT )
-import Text.Pandoc.ImageSize ( imageSize, desiredSizeInPoints )
+import Text.Pandoc.ImageSize
 import Text.Pandoc.MIME ( getMimeType, extensionFromMimeType )
 import Text.Pandoc.Definition
 import Text.Pandoc.Walk
@@ -125,22 +125,36 @@ writeODT opts doc@(Pandoc meta _) = do
                   $ addEntryToArchive metaEntry archive'
   return $ fromArchive archive''
 
+-- | transform both Image and Math elements
 transformPicMath :: WriterOptions -> IORef [Entry] -> Inline -> IO Inline
-transformPicMath opts entriesRef (Image attr lab (src,t)) = do
+transformPicMath opts entriesRef (Image attr@(id', cls, _) lab (src,t)) = do
   res <- fetchItem' (writerMediaBag opts) (writerSourceURL opts) src
   case res of
      Left (_ :: E.SomeException) -> do
        warn $ "Could not find image `" ++ src ++ "', skipping..."
        return $ Emph lab
      Right (img, mbMimeType) -> do
-       (w,h) <- case imageSize img of
-                      Right size -> return $
-                        desiredSizeInPoints opts attr size
-                      Left msg   -> do
-                        warn $ "Could not determine image size in `" ++
-                          src ++ "': " ++ msg
-                        return (0,0)
-       let tit' = show w ++ "x" ++ show h
+       (ptX, ptY) <- case imageSize img of
+                       Right s  -> return $ sizeInPoints s
+                       Left msg -> do
+                         warn $ "Could not determine image size in `" ++
+                           src ++ "': " ++ msg
+                         return (100, 100)
+       let dims =
+             case (getDim Width, getDim Height) of
+               (Just w, Just h)              -> [("width", show w), ("height", show h)]
+               (Just w@(Percent _), Nothing) -> [("width", show w), ("style:rel-height", "scale")]
+               (Nothing, Just h@(Percent _)) -> [("style:rel-width", "scale"), ("height", show h)]
+               (Just w@(Inch i), Nothing)    -> [("width", show w), ("height", show (i / ratio) ++ "in")]
+               (Nothing, Just h@(Inch i))    -> [("width", show (i * ratio) ++ "in"), ("height", show h)]
+               _                             -> [("width", show ptX ++ "pt"), ("height", show ptY ++ "pt")]
+             where
+               ratio = ptX / ptY
+               getDim dir = case (dimension dir attr) of
+                              Just (Percent i) -> Just $ Percent i
+                              Just dim         -> Just $ Inch $ inInch opts dim
+                              Nothing          -> Nothing
+       let  newattr = (id', cls, dims)
        entries <- readIORef entriesRef
        let extension = fromMaybe (takeExtension $ takeWhile (/='?') src)
                            (mbMimeType >>= extensionFromMimeType)
@@ -149,9 +163,7 @@ transformPicMath opts entriesRef (Image attr lab (src,t)) = do
        epochtime <- floor `fmap` getPOSIXTime
        let entry = toEntry newsrc epochtime $ toLazy img
        modifyIORef entriesRef (entry:)
-       let fig | "fig:" `isPrefixOf` t = "fig:"
-               | otherwise             = ""
-       return $ Image attr lab (newsrc, fig++tit')
+       return $ Image newattr lab (newsrc, t)
 transformPicMath _ entriesRef (Math t math) = do
   entries <- readIORef entriesRef
   let dt = if t == InlineMath then DisplayInline else DisplayBlock
diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs
index 8e55a4016..e0434c630 100644
--- a/src/Text/Pandoc/Writers/OpenDocument.hs
+++ b/src/Text/Pandoc/Writers/OpenDocument.hs
@@ -39,7 +39,7 @@ import Text.Pandoc.Pretty
 import Text.Printf ( printf )
 import Control.Arrow ( (***), (>>>) )
 import Control.Monad.State hiding ( when )
-import Data.Char (chr, isDigit)
+import Data.Char (chr)
 import qualified Data.Map as Map
 import Text.Pandoc.Writers.Shared
 
@@ -405,11 +405,17 @@ inlineToOpenDocument o ils
                                            , ("xlink:href" , s       )
                                            , ("office:name", t       )
                                            ] . inSpanTags "Definition"
-      mkImg _ s t = do
+      mkImg (_, _, kvs) s _ = do
                id' <- gets stImageId
                modify (\st -> st{ stImageId = id' + 1 })
+               let getDims [] = []
+                   getDims (("width", w) :xs) = ("svg:width", w)  : getDims xs
+                   getDims (("height", h):xs) = ("svg:height", h) : getDims xs
+                   getDims (x@("style:rel-width", _) :xs) = x : getDims xs
+                   getDims (x@("style:rel-height", _):xs) = x : getDims xs
+                   getDims (_:xs) =                             getDims xs
                return $ inTags False "draw:frame"
-                        (("draw:name", "img" ++ show id'):attrsFromTitle t) $
+                        (("draw:name", "img" ++ show id') : getDims kvs) $
                      selfClosingTag "draw:image" [ ("xlink:href"   , s       )
                                                  , ("xlink:type"   , "simple")
                                                  , ("xlink:show"   , "embed" )
@@ -425,17 +431,6 @@ inlineToOpenDocument o ils
         addNote nn
         return nn
 
--- a title of the form "120x140" will be interpreted as image
--- size in points.
-attrsFromTitle :: String -> [(String,String)]
-attrsFromTitle s = if null xs || null ys
-                      then []
-                      else [("svg:width",xs ++ "pt"),("svg:height",ys ++ "pt")]
-  where (xs,rest) = span isDigit s
-        ys        = case rest of
-                         ('x':zs) | all isDigit zs -> zs
-                         _ -> ""
-
 bulletListStyle :: Int -> State WriterState (Int,(Int,[Doc]))
 bulletListStyle l =
     let doStyles  i = inTags True "text:list-level-style-bullet"