{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.OOXML
   Copyright   : Copyright (C) 2012-2020 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Functions common to OOXML writers (Docx and Powerpoint)
-}
module Text.Pandoc.Writers.OOXML ( mknode
                                 , mktnode
                                 , nodename
                                 , toLazy
                                 , renderXml
                                 , parseXml
                                 , elemToNameSpaces
                                 , elemName
                                 , isElem
                                 , NameSpaces
                                 , fitToPage
                                 ) where

import Codec.Archive.Zip
import Control.Monad.Reader
import Control.Monad.Except (throwError)
import Text.Pandoc.Error
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import qualified Text.Pandoc.UTF8 as UTF8
import Text.XML.Light as XML

mknode :: Node t => String -> [(String,String)] -> t -> Element
mknode :: String -> [(String, String)] -> t -> Element
mknode String
s [(String, String)]
attrs =
  [Attr] -> Element -> Element
add_attrs (((String, String) -> Attr) -> [(String, String)] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
k,String
v) -> QName -> String -> Attr
Attr (String -> QName
nodename String
k) String
v) [(String, String)]
attrs) (Element -> Element) -> (t -> Element) -> t -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  QName -> t -> Element
forall t. Node t => QName -> t -> Element
node (String -> QName
nodename String
s)

mktnode :: String -> [(String,String)] -> T.Text -> Element
mktnode :: String -> [(String, String)] -> Text -> Element
mktnode String
s [(String, String)]
attrs = String -> [(String, String)] -> String -> Element
forall t. Node t => String -> [(String, String)] -> t -> Element
mknode String
s [(String, String)]
attrs (String -> Element) -> (Text -> String) -> Text -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

nodename :: String -> QName
nodename :: String -> QName
nodename String
s = QName :: String -> Maybe String -> Maybe String -> QName
QName{ qName :: String
qName = String
name, qURI :: Maybe String
qURI = Maybe String
forall a. Maybe a
Nothing, qPrefix :: Maybe String
qPrefix = Maybe String
prefix }
 where (String
name, Maybe String
prefix) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') String
s of
                             (String
xs,[])    -> (String
xs, Maybe String
forall a. Maybe a
Nothing)
                             (String
ys, Char
_:String
zs) -> (String
zs, String -> Maybe String
forall a. a -> Maybe a
Just String
ys)

toLazy :: B.ByteString -> BL.ByteString
toLazy :: ByteString -> ByteString
toLazy = [ByteString] -> ByteString
BL.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[])

renderXml :: Element -> BL.ByteString
renderXml :: Element -> ByteString
renderXml Element
elt = String -> ByteString
BL8.pack String
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
  String -> ByteString
UTF8.fromStringLazy (Element -> String
showElement Element
elt)

parseXml :: PandocMonad m => Archive -> Archive -> String -> m Element
parseXml :: Archive -> Archive -> String -> m Element
parseXml Archive
refArchive Archive
distArchive String
relpath =
  case String -> Archive -> Maybe Entry
findEntryByPath String
relpath Archive
refArchive Maybe Entry -> Maybe Entry -> Maybe Entry
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
         String -> Archive -> Maybe Entry
findEntryByPath String
relpath Archive
distArchive of
            Maybe Entry
Nothing -> PandocError -> m Element
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m Element) -> PandocError -> m Element
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$
                        String -> Text
T.pack String
relpath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" missing in reference file"
            Just Entry
e  -> case String -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc (String -> Maybe Element)
-> (Entry -> String) -> Entry -> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
UTF8.toStringLazy (ByteString -> String) -> (Entry -> ByteString) -> Entry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> ByteString
fromEntry (Entry -> Maybe Element) -> Entry -> Maybe Element
forall a b. (a -> b) -> a -> b
$ Entry
e of
                       Maybe Element
Nothing -> PandocError -> m Element
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m Element) -> PandocError -> m Element
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$
                                   String -> Text
T.pack String
relpath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" corrupt in reference file"
                       Just Element
d  -> Element -> m Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
d

-- Copied from Util

attrToNSPair :: XML.Attr -> Maybe (String, String)
attrToNSPair :: Attr -> Maybe (String, String)
attrToNSPair (XML.Attr (QName String
s Maybe String
_ (Just String
"xmlns")) String
val) = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
s, String
val)
attrToNSPair Attr
_                                     = Maybe (String, String)
forall a. Maybe a
Nothing


elemToNameSpaces :: Element -> NameSpaces
elemToNameSpaces :: Element -> [(String, String)]
elemToNameSpaces = (Attr -> Maybe (String, String)) -> [Attr] -> [(String, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Attr -> Maybe (String, String)
attrToNSPair ([Attr] -> [(String, String)])
-> (Element -> [Attr]) -> Element -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Attr]
elAttribs

elemName :: NameSpaces -> String -> String -> QName
elemName :: [(String, String)] -> String -> String -> QName
elemName [(String, String)]
ns String
prefix String
name =
  String -> Maybe String -> Maybe String -> QName
QName String
name (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
prefix [(String, String)]
ns) (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
prefix then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
prefix)

isElem :: NameSpaces -> String -> String -> Element -> Bool
isElem :: [(String, String)] -> String -> String -> Element -> Bool
isElem [(String, String)]
ns String
prefix String
name Element
element =
  let ns' :: [(String, String)]
ns' = [(String, String)]
ns [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ Element -> [(String, String)]
elemToNameSpaces Element
element
  in QName -> String
qName (Element -> QName
elName Element
element) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name Bool -> Bool -> Bool
&&
     QName -> Maybe String
qURI (Element -> QName
elName Element
element) Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
prefix [(String, String)]
ns'

type NameSpaces = [(String, String)]

-- | Scales the image to fit the page
-- sizes are passed in emu
fitToPage :: (Double, Double) -> Integer -> (Integer, Integer)
fitToPage :: (Double, Double) -> Integer -> (Integer, Integer)
fitToPage (Double
x, Double
y) Integer
pageWidth
  -- Fixes width to the page width and scales the height
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pageWidth =
    (Integer
pageWidth, Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
pageWidth Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
x) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y)
  | Bool
otherwise = (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
x, Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
y)