{-# LANGUAGE OverloadedStrings #-}
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 s :: String
s attrs :: [(String, String)]
attrs =
[Attr] -> Element -> Element
add_attrs (((String, String) -> Attr) -> [(String, String)] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map (\(k :: String
k,v :: 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 s :: String
s attrs :: [(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 s :: 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 (name :: String
name, prefix :: 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
==':') String
s of
(xs :: String
xs,[]) -> (String
xs, Maybe String
forall a. Maybe a
Nothing)
(ys :: String
ys, _:zs :: 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 elt :: Element
elt = String -> ByteString
BL8.pack "<?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 refArchive :: Archive
refArchive distArchive :: Archive
distArchive relpath :: 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
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
<> " missing in reference file"
Just e :: 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
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
<> " corrupt in reference file"
Just d :: Element
d -> Element -> m Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
d
attrToNSPair :: XML.Attr -> Maybe (String, String)
attrToNSPair :: Attr -> Maybe (String, String)
attrToNSPair (XML.Attr (QName s :: String
s _ (Just "xmlns")) val :: String
val) = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
s, String
val)
attrToNSPair _ = 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 ns :: [(String, String)]
ns prefix :: String
prefix name :: 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 ns :: [(String, String)]
ns prefix :: String
prefix name :: String
name element :: 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)]
fitToPage :: (Double, Double) -> Integer -> (Integer, Integer)
fitToPage :: (Double, Double) -> Integer -> (Integer, Integer)
fitToPage (x :: Double
x, y :: Double
y) pageWidth :: Integer
pageWidth
| 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)