{-# 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 (mplus)
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 :: forall t. Node t => 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{ 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 :: forall (m :: * -> *).
PandocMonad m =>
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 a. Maybe a -> Maybe a -> Maybe a
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 a. PandocError -> m a
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 a. PandocError -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Element
d
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)]
fitToPage :: (Double, Double) -> Integer -> (Integer, Integer)
fitToPage :: (Double, Double) -> Integer -> (Integer, Integer)
fitToPage (Double
x, Double
y) 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 b. Integral b => Double -> b
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 b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
x, Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
y)