{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.OOXML
   Copyright   : Copyright (C) 2012-2021 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 Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Data.Text (Text)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.XML.Light

mknode :: Node t => Text -> [(Text,Text)] -> t -> Element
mknode :: Text -> [(Text, Text)] -> t -> Element
mknode Text
s [(Text, Text)]
attrs =
  [Attr] -> Element -> Element
add_attrs (((Text, Text) -> Attr) -> [(Text, Text)] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k,Text
v) -> QName -> Text -> Attr
Attr (Text -> QName
nodename Text
k) Text
v) [(Text, Text)]
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 (Text -> QName
nodename Text
s)

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

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

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 = ByteString -> ByteString
BL.fromStrict (Text -> ByteString
UTF8.fromText (Element -> Text
showTopElement 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 Text -> Either Text Element
parseXMLElement (Text -> Either Text Element)
-> (Entry -> Text) -> Entry -> Either Text Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
UTF8.toTextLazy (ByteString -> Text) -> (Entry -> ByteString) -> Entry -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> ByteString
fromEntry (Entry -> Either Text Element) -> Entry -> Either Text Element
forall a b. (a -> b) -> a -> b
$ Entry
e of
                       Left Text
msg ->
                         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 -> Text -> PandocError
PandocXMLError (String -> Text
T.pack String
relpath) Text
msg
                       Right Element
d  -> Element -> m Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
d

-- Copied from Util

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


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

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

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

type NameSpaces = [(Text, Text)]

-- | 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)