-import Data.Aeson (defaultOptions, eitherDecode', encode)

-import Data.Foldable (foldrM)

-import System.Directory (Permissions (..), doesFileExist, findExecutable,

- getAppUserDataDirectory, getPermissions)

-import System.Environment (getArgs, getEnvironment, getProgName)

-import System.Exit (ExitCode (..), exitSuccess)

-import Text.Pandoc.Lua (LuaException (..), runLuaFilter)

-import Text.Pandoc.Process (pipeProcess)

-externalFilter :: MonadIO m

- => ReaderOptions -> FilePath -> [String] -> Pandoc -> m Pandoc

-externalFilter ropts f args' d = liftIO $ do

- exists <- doesFileExist f

- isExecutable <- if exists

- then executable <$> getPermissions f

- else return True

- let (f', args'') = if exists

- then case map toLower (takeExtension f) of

- _ | isExecutable -> ("." </> f, args')

- ".py" -> ("python", f:args')

- ".hs" -> ("runhaskell", f:args')

- ".pl" -> ("perl", f:args')

- ".rb" -> ("ruby", f:args')

- ".php" -> ("php", f:args')

- ".js" -> ("node", f:args')

- ".r" -> ("Rscript", f:args')

- _ -> (f, args')

- else (f, args')

- unless (exists && isExecutable) $ do

- mbExe <- findExecutable f'

- when (isNothing mbExe) $

- E.throwIO $ PandocFilterError f ("Could not find executable " ++ f')

- env <- getEnvironment

- let env' = Just

- ( ("PANDOC_VERSION", pandocVersion)

- : ("PANDOC_READER_OPTIONS", UTF8.toStringLazy (encode ropts))

- : env )

- (exitcode, outbs) <- E.handle filterException $

- pipeProcess env' f' args'' $ encode d

- case exitcode of

- ExitSuccess -> either (E.throwIO . PandocFilterError f)

- return $ eitherDecode' outbs

- ExitFailure ec -> E.throwIO $ PandocFilterError f

- ("Filter returned error status " ++ show ec)

- where filterException :: E.SomeException -> IO a

- filterException e = E.throwIO $ PandocFilterError f (show e)

-

-data Filter = LuaFilter FilePath

- | JSONFilter FilePath

- deriving (Show)

-

- -- First we check to see if a filter is found. If not, and if it's

- -- not an absolute path, we check to see whether it's in `userdir/filters`.

- -- If not, we leave it unchanged.

-expandFilterPath :: PandocMonad m => FilePath -> m FilePath

-expandFilterPath fp = do

- mbDatadir <- getUserDataDir

- fpExists <- fileExists fp

- if fpExists

- then return fp

- else case mbDatadir of

- Just datadir | isRelative fp -> do

- let filterPath = datadir </> "filters" </> fp

- filterPathExists <- fileExists filterPath

- if filterPathExists

- then return filterPath

- else return fp

- _ -> return fp

-

-applyFilters :: ReaderOptions

- -> [Filter]

- -> [String]

- -> Pandoc

- -> PandocIO Pandoc

-applyFilters ropts filters args d = do

- foldrM ($) d $ map (applyFilter ropts args) filters

-

-applyFilter :: ReaderOptions

- -> [String]

- -> Filter

- -> Pandoc

- -> PandocIO Pandoc

-applyFilter _ropts args (LuaFilter f) d = do

- f' <- expandFilterPath f

- let format = case args of

- (x:_) -> x

- _ -> error "Format not supplied for lua filter"

- res <- runLuaFilter f' format d

- case res of

- Right x -> return x

- Left (LuaException s) -> E.throw (PandocFilterError f s)

-applyFilter ropts args (JSONFilter f) d = do

- f' <- expandFilterPath f

- liftIO $ externalFilter ropts f' args d

-

-$(deriveJSON defaultOptions ''Filter)

-import System.FilePath ((</>), (<.>), takeDirectory,

- takeExtension, dropExtension, isRelative, normalise)

-import System.FilePath (splitDirectories)

-runLuaFilter :: FilePath -> String

-runLuaFilter filterPath format doc =

- runPandocLua (runLuaFilter' filterPath format doc)

-runLuaFilter' :: FilePath -> String

-runLuaFilter' filterPath format pd = do

- -- store module in global "pandoc"

- luaFilters <- if (newtop - top >= 1)

- let topOfStack = Lua.StackIndex (-1)

- Left _ -> Lua.toList topOfStack <* Lua.pop 1

-import Text.Pandoc.Lua.Util (addFunction)

-pushModule :: Lua NumResults

-pushModule = do

- "pandoc.utils" -> pushWrappedHsFun Utils.pushModule

-

-{-# LANGUAGE FlexibleInstances #-}

-{-# LANGUAGE LambdaCase #-}

-import Text.Pandoc.Lua.Util (adjustIndexBy, getTable, pushViaConstructor)

- peek idx = do

- meta <- getTable idx "meta"

- peek idx = Meta <$> peek idx

-peekMetaValue idx = do

-peekBlock idx = do

-peekInline idx = do

- r <- tryLua (peek (-1))

- Lua.settop top

- case r of

- Left (Lua.LuaException err) -> throwLuaError err

- Right res -> return res

- peek idx = LuaAttr <$> peek idx

-import Data.Char (chr, isAlphaNum, isAscii, isAsciiUpper, isHexDigit, isPunctuation, isSpace,

- ord, toLower, toUpper)

-import Data.Maybe (mapMaybe)

- if (num < tabStop)

- <|> (try $ punct >>

-anyOrderedListMarker = choice $

- fracs = map (\l -> (fromIntegral l) / quotient) lengths in

- heads <- fmap sequence $ mapM (parseFromString blocks . trim) rawHeads

- if context' == context

- then fail "already inside quotes"

- else return ()

- ident' = case lookup "id" kvs of

- Just v -> v

- Nothing -> ident

-import Data.Maybe (isJust)

- , (c : _)<- intersect (pStyle pPr) (M.keys metaStyles)

- unless (null $ filter notParaOrPlain blkList) $

- (BookMark _ anchor) | not $ anchor `elem` dummyAnchors -> do

-parPartToInlines' (SmartTag runs) = do

- Nothing -> case startFromLevelInfo of

- Just n' -> n'

- Nothing -> 1

-getLevel (Div (_, _, kvs) _) = fmap read $ lookup "level" kvs

-getNumId (Div (_, _, kvs) _) = fmap read $ lookup "num-id" kvs

- (getLevelN b') > bLevel ||

- ((getLevelN b') == bLevel && (getNumIdN b') == bNumId))

-data ReaderState = ReaderState { stateWarnings :: [String] }

-data DocxError = DocxError | WrongElem

- rState = ReaderState { stateWarnings = [] }

- let bodyElem' = case walkDocument namespaces bodyElem of

- Just e -> e

- Nothing -> bodyElem

- return $ TblLook{firstRowFormatting = firstRowFmt}

- Just $ ParIndentation {

- | isElem ns "w" "r" element =

- elemToRun ns element >>= (\r -> return $ PlainRun r)

- foldr (<|>) Nothing (

- map (flip findAttr fontElem . qualName) ["ascii", "hAnsi"])

-import Control.Arrow ((***))

-import Data.List (intercalate, isPrefixOf)

- return $ case lookup "width" attribs of

- fromMaybe 0.0 $ safeRead ('0':'.':filter

- fromMaybe 0.0 $ safeRead ('0':'.':init x)

- return $ B.codeWith (mkAttr attr) $ intercalate " " $ lines $ T.unpack $

- TagOpen (stripPrefix' s) (map (stripPrefix' *** id) as)

-

- (do (_, raw) <- rawLaTeXParser macroDef

- (guardDisabled Ext_latex_macros >> return raw) <|> return "")

- <|> (do (_, raw) <- rawLaTeXParser (environment <|> blockCommand)

- applyMacros raw)

- : totoks (incSourceColumn pos 1) r1

- Tok pos (CtrlSeq " ") ("\\" <> w1 <> w2 <> w3)

- : totoks (incSourceColumn pos 1) r3

- Tok pos Symbol ("#")

- _ -> Tok pos Symbol ("^") :

- Tok (incSourceColumn pos 1) Symbol ("^") :

- _ -> Tok pos Symbol ("^")

- updatePos spos _ [] = spos

- let addTok (Tok _ (Arg i) _) acc | i > 0

- , i <= numargs =

- foldr addTok acc (args !! (i - 1))

- addTok (Tok _ (CtrlSeq x) txt)

- (isLetter (T.last txt)) =

- addTok t acc = setpos spos t : acc

- setInput $ foldr addTok ts' newtoks

-inlineCommands = M.union inlineLanguageCommands $ M.fromList $

- Just lang -> spanWith ("", [], [("lang", renderLang $ lang)]) <$> tok

-blockCommands = M.fromList $

- , ("tabular*", env "tabular" $ simpTable "tabular*" True)

- Just n -> do

-import Data.List (findIndex, intercalate, sortBy, transpose)

-inlinesInBalancedBrackets = try $ char '[' >> go 1

- where go :: PandocMonad m => Int -> MarkdownParser m (F Inlines)

- go 0 = return mempty

- go openBrackets =

- (mappend <$> (bracketedSpan <|> link <|> image) <*>

- go openBrackets)

- <|> ((if openBrackets > 1

- then (return (B.str "]") <>)

- else id) <$>

- (char ']' >> go (openBrackets - 1)))

- <|> ((return (B.str "[") <>) <$>

- (char '[' >> go (openBrackets + 1)))

- <|> (mappend <$> inline <*> go openBrackets)

- (do m <- stateMeta' st

- -- if there's already a value, leave it unchanged

- case lookupMeta k' m of

- Just _ -> return m

- Nothing -> do

- v'' <- v'

- return $ B.setMeta (T.unpack k) v'' m)}

- let level = fromMaybe 0 (findIndex (== underlineChar) setextHChars) + 1

-listStart = bulletListStart <|> (Control.Monad.void (orderedListStart Nothing))

- else (sourceColumn pos2 - sourceColumn pos1)

-notFollowedByDivCloser = do

- do divLevel <- stateFencedDivLevel <$> getState

- guard (divLevel < 1) <|> notFollowedBy divFenceEnd

- <*> (blanklines <|> many spaceChar)))

- many1 ((++) <$> rawLaTeXBlock

- <*> (blanklines <|> many spaceChar)))

- let aligns = zipWith alignType (map ((: [])) rawHeads) lengths

- ((case (left,right) of

- (Nothing,Nothing) -> AlignDefault

- (Just _,Nothing) -> AlignLeft

- (Nothing,Just _) -> AlignRight

- (Just _,Just _) -> AlignCenter), len)

-inBrackets :: PandocMonad m => (ParserT [Char] st m Char) -> ParserT [Char] st m String

- nonindentSpaces

- nonindentSpaces

- (withQuoteContext InDoubleQuote $ doubleQuoteEnd >> return

- <|> (return $ return (B.str "\8220") <> contents)

-import Data.List (stripPrefix)

- blocks <- parseBlocks

-parseBlocks :: PandocMonad m => MuseParser m (F Blocks)

-parseBlocks = do

- res <- mconcat <$> many block

- spaces

- eof

- return res

-

- space

- spaces

- raw <- manyTill anyChar eol

- value <- parseFromString (trimInlinesF . mconcat <$> many inline) raw

-block :: PandocMonad m => MuseParser m (F Blocks)

-block = do

- res <- mempty <$ skipMany1 blankline

- <|> blockElements

- <|> para

- skipMany blankline

-blockElements = choice [ comment

- optionMaybe (spaceChar >> (many $ noneOf "\n"))

- where lchop s = case s of

- rchop = reverse . lchop . reverse

-exampleTag = do

- return $ return $ B.codeBlockWith attr $ chop contents

- optionMaybe blankline -- Skip blankline after opening tag on separate line

- parseFromString verseLines content

- endOfParaElement = lookAhead $ endOfInput <|> endOfPara <|> newBlockElement

- endOfPara = try $ blankline >> skipMany1 blankline

- content <- listItemContents $ 3 + length ref

-lineVerseLine :: PandocMonad m => MuseParser m String

- char '>'

- white <- many1 (char ' ' >> pure '\160')

- rest <- anyLine

- return $ tail white ++ rest

-blanklineVerseLine :: PandocMonad m => MuseParser m Char

-blanklineVerseLine = try $ char '>' >> blankline

- lns <- many1 (pure <$> blanklineVerseLine <|> lineVerseLine)

- lns' <- mapM (parseFromString' (trimInlinesF . mconcat <$> many inline)) lns

- return $ B.lineBlock <$> sequence lns'

-listLine :: PandocMonad m => Int -> MuseParser m String

-listLine markerLength = try $ do

- indentWith markerLength

- manyTill anyChar eol

-

-listContinuation :: PandocMonad m => Int -> MuseParser m [String]

-listContinuation markerLength = try $ do

- result <- many1 $ listLine markerLength

- blank <- option id ((++ [""]) <$ blankline)

- return $ blank result

-

-listStart :: PandocMonad m => MuseParser m Int -> MuseParser m Int

-listStart marker = try $ do

- preWhitespace <- length <$> many spaceChar

- st <- stateParserContext <$> getState

- getPosition >>= \pos -> guard (st == ListItemState || sourceColumn pos /= 1)

- markerLength <- marker

- void spaceChar <|> eol

- return $ preWhitespace + markerLength + 1

-

-dropSpacePrefix :: [String] -> [String]

-dropSpacePrefix lns =

- map (drop maxIndent) lns

- where flns = filter (not . all (== ' ')) lns

- maxIndent = if null flns then 0 else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns

-

-listItemContents :: PandocMonad m => Int -> MuseParser m (F Blocks)

-listItemContents markerLength = do

- firstLine <- manyTill anyChar eol

- restLines <- many $ listLine markerLength

- blank <- option id ((++ [""]) <$ blankline)

- let first = firstLine : blank restLines

- rest <- many $ listContinuation markerLength

- let allLines = concat (first : rest)

- parseFromString (withListContext parseBlocks) $ unlines (dropSpacePrefix allLines)

-

-listItem :: PandocMonad m => MuseParser m Int -> MuseParser m (F Blocks)

-listItem start = try $ do

- markerLength <- start

- listItemContents markerLength

-bulletListItems :: PandocMonad m => MuseParser m (F [Blocks])

-bulletListItems = sequence <$> many1 (listItem bulletListStart)

-bulletListStart :: PandocMonad m => MuseParser m Int

-bulletListStart = listStart (char '-' >> return 1)

-bulletList = do

- listItems <- bulletListItems

- return $ B.bulletList <$> listItems

-

-orderedListStart :: PandocMonad m

- => ListNumberStyle

- -> ListNumberDelim

- -> MuseParser m Int

-orderedListStart style delim = listStart (snd <$> withHorizDisplacement (orderedListMarker style delim))

- p@(_, style, delim) <- lookAhead (many spaceChar *> anyOrderedListMarker <* (eol <|> void spaceChar))

- items <- sequence <$> many1 (listItem $ orderedListStart style delim)

- return $ B.orderedListWith p <$> items

-

-definitionListItem :: PandocMonad m => MuseParser m (F (Inlines, [Blocks]))

-definitionListItem = try $ do

- rawTerm <- termParser

- term <- parseFromString (trimInlinesF . mconcat <$> many inline) rawTerm

- many1 spaceChar

- string "::"

- firstLine <- manyTill anyChar eol

- restLines <- manyTill anyLine endOfListItemElement

- let lns = dropWhile (== ' ') firstLine : dropSpacePrefix restLines

- lineContent <- parseFromString (withListContext parseBlocks) $ unlines lns

- pure $ do lineContent' <- lineContent

- where

- termParser = (guardDisabled Ext_amuse <|> void spaceChar) >> -- Initial space is required by Amusewiki, but not Emacs Muse

- many spaceChar >>

- many1Till (noneOf "\n") (lookAhead (void (try (spaceChar >> string "::"))))

- endOfInput = lookAhead $ try $ skipMany blankline >> skipSpaces >> eof

- twoBlankLines = try $ blankline >> skipMany1 blankline

- newDefinitionListItem = try $ void termParser

- endOfListItemElement = lookAhead $ endOfInput <|> newDefinitionListItem <|> twoBlankLines

-

-definitionListItems :: PandocMonad m => MuseParser m (F [(Inlines, [Blocks])])

-definitionListItems = sequence <$> many1 definitionListItem

-definitionList = do

- listItems <- definitionListItems

- return $ B.definitionList <$> listItems

- contents <- trimInlinesF . mconcat <$> many1Till inline (lookAhead $ string "+|")

- string "+|"

- return $ MuseCaption contents

-inlineList = [ endline

- , whitespace

-inline = choice inlineList <?> "inline"

-whitespace = fmap return (lb <|> regsp)

- where lb = try $ skipMany spaceChar >> linebreak >> return B.space

- regsp = try $ skipMany1 spaceChar >> return B.space

-linebreak :: PandocMonad m => MuseParser m (F Inlines)

-linebreak = newline >> notFollowedBy newline >> (lastNewline <|> innerNewline)

- where lastNewline = do

- eof

- return $ return mempty

- innerNewline = return $ return B.space

-

-nbsp = do

- guardDisabled Ext_amuse -- Supported only by Emacs Muse

- pos <- getPosition

- sp <- if sourceColumn pos == 1

- then pure mempty

- else skipMany1 spaceChar >> pure B.space

- char '='

- return $ return (sp B.<> B.code contents)

- (attrs, content) <- parseHtmlContentWithAttrs "code" anyChar

- res <- many1Till anyChar $ char ']'

- parseFromString (mconcat <$> many1 inline) res

- -> (b -> b' -> (Either f c))

-a >>?%? f = a >>?^? (uncurry f)

- (getVPosModifier propertyTriple)

- maybe True (/=newProperty) (lookupPreviousValue property triple)

- = ( findBy f $ extendedStylePropertyChain styleTrace styleSet )

-read_frame_title = matchingElement NsSVG "title"

- $ (matchChildContent [] read_plain_text)

-read_img_with_caption ((Para [Image attr alt (src,title)]) : _) =

-read_img_with_caption ( (Para (_ : xs)) : ys) =

- read_img_with_caption ((Para xs) : ys)

-post_process' ((Table _ a w h r) : (Div ("", ["caption"], _) [Para inlines] ) : xs) =

- (Table inlines a w h r) : ( post_process' xs )

-findID iri = listToMaybe [nsID | (iri',~nsID) <- nsIDs, iri' `isPrefixOf` iri]

- ( withEveryL NsStyle "font-face" $ liftAsSuccess (

- )

- )

- >>?^ ( M.fromList . (foldl accumLegalPitches []) )

- ++ (show listLevelType)

- ++ (maybeToString listItemPrefix)

- ++ (show listItemFormat)

- ++ (maybeToString listItemSuffix)

- ( findPitch )

- ( readUnderlineMode )

- ( readStrikeThroughMode )

- :(map ((,True).show) ([100,200..900]::[Int]))

- isLinePresent = [("none",False)] ++ map (,True)

- $ ( liftA3 SM.union3

- ( readListLevelStyles NsText "list-level-style-image" LltImage )

- ) >>^ M.mapMaybe chooseMostSpecificListLevelStyle

- ( tryAll namespace elementName (readListLevelStyle levelType)

- )

- <|> (F.asum $ map (`getStyleFamily` styles) $ parents style styles)

-extendedStylePropertyChain [style] styles = (stylePropertyChain style styles)

- ++ (maybeToList (fmap (lookupDefaultStyle' styles) (getStyleFamily style styles)))

-extendedStylePropertyChain (style:trace) styles = (stylePropertyChain style styles)

- ++ (extendedStylePropertyChain trace styles)

- ("export" : format : []) -> return $ pure . B.rawBlock format <$> parseRaw

- txt <- trimInlines . mconcat <$> many1 (do {notFollowedBy newline; inline})

--- divide string by blanklines

- . map (trim . unlines)

- -- put identifier on next block:

- return $ foldr addDiv b refs

- heads <- mapM ( (parseFromString' (mconcat <$> many plain)) . trim) rawHeads

-addClass c (ident, classes, keyValues) = (ident, union classes [c], keyValues)

- when ((stateParserContext st) == ListItemState) $ notFollowedBy (anyOrderedListMarker >> spaceChar) >>

- let newnotes = if (ref == "*" || ref == "#") -- auto-numbered

- contents <- fmap unlines $ many1Till anyLine (blanklines <|> noteBlock)

- (isHeader, alignment) <- option (False, AlignDefault) $ cellAttributes

- ref <- (char '[' *> many1 digit <* char ']')

- tl <- many ( (noneOf wordBoundaries) <|>

- (try $ string "<notextile>" *>

- satisfy (/='\n') <|> (try $ char '\n' <* notFollowedBy blankline)

- headers rows = map (B.plain . B.str) $replicate (length $ rows !! 0) ""

- BulletList _ -> fixListNesting $ (mappend (recurseOnList first) (recurseOnList second)) : rest

- OrderedList _ _ -> fixListNesting $ (mappend (recurseOnList first) (recurseOnList second)) : rest

- | (lnnest ln1) < (lnnest ln2) =

- return $ filterSpaces content ++ "\n" ++ maybe "" id continuation

-whitespace = (lb <|> regsp)

- return $B.str [(toEnum (read inner :: Int)) :: Char]

-import Data.List (intercalate, intersperse, transpose)

- let tit = concat (intersperse " " (init tokens))

- ("ol" <$choice (orderedListMarker Decimal Period:(($OneParen)

- <$> orderedListMarker

- <$> [Decimal, LowerRoman, UpperRoman, LowerAlpha, UpperAlpha])))

- hierarchicalizeWithIds (Header level (ident,("references":classes),kvs)

- contents <- mapM (uncurry (orderedListItemToAsciiDoc opts)) $

- zip markers' items

- let txt = if (null alternate) || (alternate == [Str ""])

- let colDescriptor colWidth alignment = (case alignment of

- AlignLeft -> 'l'

- AlignRight -> 'r'

- AlignCenter -> 'c'

- AlignDefault -> 'l'):

- if colWidth == 0

- then "|"

- else ("p(" ++ printf "%.2f" colWidth ++ "\\textwidth)|")

- let colDescriptors = "|" ++ concat (

- zipWith colDescriptor widths aligns)

- headers <- if all null heads

- then return empty

- else liftM ($$ "\\HL") $ tableRowToConTeXt heads

- rows' <- mapM tableRowToConTeXt rows

- return $ "\\placetable" <> (if null caption

- then brackets "none"

- else empty)

- <> braces captionText $$

- "\\starttable" <> brackets (text colDescriptors) $$

- "\\HL" $$ headers $$

- vcat rows' $$ "\\HL" $$ "\\stoptable" <> blankline

-

-tableRowToConTeXt :: PandocMonad m => [[Block]] -> WM m Doc

-tableRowToConTeXt cols = do

- cols' <- mapM blockListToConTeXt cols

- return $ vcat (map ("\\NC " <>) cols') $$ "\\NC\\AR"

-

-import Text.Pandoc.Writers.Shared (fixDisplayMath)

-metaValueToInlines :: MetaValue -> [Inline]

-metaValueToInlines (MetaString s) = [Str s]

-metaValueToInlines (MetaInlines ils) = ils

-metaValueToInlines (MetaBlocks bs) = query return bs

-metaValueToInlines (MetaBool b) = [Str $ show b]

-metaValueToInlines _ = []

-

-

-

- let listPr = if listLevel >= 0 && not displayMathPara

- then [ mknode "w:numPr" []

- [ mknode "w:numId" [("w:val",show numid)] ()

- , mknode "w:ilvl" [("w:val",show listLevel)] () ]

- ]

- else []

- [("w:id", (show insId)),

- ident <- ("rId"++) `fmap` ((lift . lift) getUniqueId)

- , el "document-info" ([ el "program-used" "pandoc" ] -- FIXME: +version

- ++ coverpage)

- let isSec (Sec{}) = True

- let path = fromMaybe fp (uriPath `fmap` parseURIReference fp)

- let attribs = ([A.start $ toValue startnum | startnum /= 1]) ++

- ([A.class_ "example" | numstyle == Example]) ++

- defs' <- mapM (liftM (\x -> H.dd $ (x >> nl opts)) .

- contents <- mapM (uncurry (orderedListItemToHaddock opts)) $

- zip markers' items

- [snd rule | isInfixOf (fst rule) s]

- $$ inTags False "Destination" [("type","object")] (text $ "HyperlinkURLDestination/"++(escapeColons (escapeStringForXML url))) -- HyperlinkURLDestination with more than one colon crashes CS6

-import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)

- let optionslist = ["fragile" | fragile && lookup "fragile" kvs == Nothing] ++

- let widths' = if not (all isSimple cols)

- (0.97 / fromIntegral (length aligns))

- | (Header _ _ _ :_) <- lst =

- removeInvalidInline (Image{}) = []

- let str' = escapeStringUsing (backslashEscapes "\\{}%~_") str

- else mapM (uncurry (noteToMan opts)) (zip [1..] notes) >>=

- max (floor $ fromIntegral (writerColumns opts) * w)

- contents <- liftM vcat $ mapM blockListToMuse defs

- let label'' = label' <> " :: "

- let ind = offset label''

- return $ hang ind label'' contents

- , nodename

- , toLazy

- , renderXml

- , parseXml

- , elemToNameSpaces

- , elemName

- , isElem

- , NameSpaces

- , fitToPage

- ) where

---import Control.Applicative ((<|>))

--- import Control.Monad.Except (catchError)

--- import Control.Monad.State

--- import Data.Char (isSpace, ord, toLower)

--- import Data.List (intercalate, isPrefixOf, isSuffixOf)

--- import qualified Data.Map as M

--- import qualified Data.Set as Set

--- import qualified Data.Text as T

--- import Data.Time.Clock.POSIX

--- import Skylighting

--- import System.Random (randomR)

--- import qualified Text.Pandoc.Class as P

--- import Text.Pandoc.Compat.Time

--- import Text.Pandoc.Definition

--- import Text.Pandoc.Generic

--- import Text.Pandoc.Highlighting (highlight)

--- import Text.Pandoc.ImageSize

--- import Text.Pandoc.Logging

--- import Text.Pandoc.MIME (MimeType, extensionFromMimeType, getMimeType,

--- getMimeTypeDef)

--- import Text.Pandoc.Options

--- import Text.Pandoc.Readers.Docx.StyleMap

--- import Text.Pandoc.Shared hiding (Element)

--- import Text.Pandoc.Walk

--- import Text.Pandoc.Writers.Math

--- import Text.Pandoc.Writers.Shared (fixDisplayMath)

--- import Text.Printf (printf)

--- import Text.TeXMath

--- import Text.XML.Light.Cursor as XMLC

-

- (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y)

-

- indent = if (i /= 0 || b)

-{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-}

-Conversion of 'Pandoc' documents to powerpoint (pptx).

-import Control.Monad.Except (throwError)

-import Control.Monad.Reader

-import Control.Monad.State

-import Data.List (intercalate, stripPrefix, isPrefixOf, nub)

-import Data.Default

-import Data.Time.Clock (UTCTime)

-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)

-import System.FilePath.Posix (splitDirectories, splitExtension)

-import Text.XML.Light

-import qualified Text.XML.Light.Cursor as XMLC

-import qualified Text.Pandoc.UTF8 as UTF8

-import Text.Pandoc.Class (PandocMonad)

-import Text.Pandoc.Error (PandocError(..))

-import Text.Pandoc.Slides (getSlideLevel)

-import qualified Text.Pandoc.Class as P

-import Text.Pandoc.Options

-import Text.Pandoc.MIME

-import Text.Pandoc.Logging

-import qualified Data.ByteString.Lazy as BL

-import Text.Pandoc.Writers.OOXML

-import qualified Data.Map as M

-import Data.Maybe (mapMaybe, listToMaybe, maybeToList)

-import Text.Pandoc.ImageSize

-import Control.Applicative ((<|>))

-

-import Text.TeXMath

-import Text.Pandoc.Writers.Math (convertMath)

-

- distArchive <- (toArchive . BL.fromStrict) <$>

- P.readDefaultDataFile "reference.pptx"

- refArchive <- case writerReferenceDoc opts of

- Just f -> toArchive <$> P.readFileLazy f

- Nothing -> (toArchive . BL.fromStrict) <$>

- P.readDataFile "reference.pptx"

-

- utctime <- P.getCurrentTime

-

- let env = def { envMetadata = meta

- , envRefArchive = refArchive

- , envDistArchive = distArchive

- , envUTCTime = utctime

- , envOpts = opts

- , envSlideLevel = case writerSlideLevel opts of

- Just n -> n

- Nothing -> getSlideLevel blks'

- }

- runP env def $ do pres <- blocksToPresentation blks'

- archv <- presentationToArchive pres

- return $ fromArchive archv

-

-concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]

-concatMapM f xs = liftM concat (mapM f xs)

-

-data WriterEnv = WriterEnv { envMetadata :: Meta

- , envRunProps :: RunProps

- , envParaProps :: ParaProps

- , envSlideLevel :: Int

- , envRefArchive :: Archive

- , envDistArchive :: Archive

- , envUTCTime :: UTCTime

- , envOpts :: WriterOptions

- , envPresentationSize :: PresentationSize

- , envSlideHasHeader :: Bool

- , envInList :: Bool

- , envInNoteSlide :: Bool

- }

- deriving (Show)

-

-instance Default WriterEnv where

- def = WriterEnv { envMetadata = mempty

- , envRunProps = def

- , envParaProps = def

- , envSlideLevel = 2

- , envRefArchive = emptyArchive

- , envDistArchive = emptyArchive

- , envUTCTime = posixSecondsToUTCTime 0

- , envOpts = def

- , envPresentationSize = def

- , envSlideHasHeader = False

- , envInList = False

- , envInNoteSlide = False

- }

-

-data MediaInfo = MediaInfo { mInfoFilePath :: FilePath

- , mInfoLocalId :: Int

- , mInfoGlobalId :: Int

- , mInfoMimeType :: Maybe MimeType

- , mInfoExt :: Maybe String

- , mInfoCaption :: Bool

- } deriving (Show, Eq)

-

-data WriterState = WriterState { stCurSlideId :: Int

- -- the difference between the number at

- -- the end of the slide file name and

- -- the rId number

- , stSlideIdOffset :: Int

- , stLinkIds :: M.Map Int (M.Map Int (URL, String))

- -- (FP, Local ID, Global ID, Maybe Mime)

- , stMediaIds :: M.Map Int [MediaInfo]

- , stMediaGlobalIds :: M.Map FilePath Int

- , stNoteIds :: M.Map Int [Block]

- } deriving (Show, Eq)

-

-instance Default WriterState where

- def = WriterState { stCurSlideId = 0

- , stSlideIdOffset = 1

- , stLinkIds = mempty

- , stMediaIds = mempty

- , stMediaGlobalIds = mempty

- , stNoteIds = mempty

- }

-

-type P m = ReaderT WriterEnv (StateT WriterState m)

-

-runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a

-runP env st p = evalStateT (runReaderT p env) st

-

-type Pixels = Integer

-

-data Presentation = Presentation PresentationSize [Slide]

- deriving (Show)

-

-data PresentationSize = PresentationSize { presSizeWidth :: Pixels

- , presSizeRatio :: PresentationRatio

- }

- deriving (Show, Eq)

-

-data PresentationRatio = Ratio4x3

- | Ratio16x9

- | Ratio16x10

- deriving (Show, Eq)

-

--- Note that right now we're only using Ratio4x3.

-getPageHeight :: PresentationSize -> Pixels

-getPageHeight sz = case presSizeRatio sz of

- Ratio4x3 -> floor (((fromInteger (presSizeWidth sz)) / 4) * 3 :: Double)

- Ratio16x9 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 9 :: Double)

- Ratio16x10 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 10 :: Double)

-

-instance Default PresentationSize where

- def = PresentationSize 720 Ratio4x3

-

-data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem]

- , metadataSlideSubtitle :: [ParaElem]

- , metadataSlideAuthors :: [[ParaElem]]

- , metadataSlideDate :: [ParaElem]

- }

- | TitleSlide { titleSlideHeader :: [ParaElem]}

- | ContentSlide { contentSlideHeader :: [ParaElem]

- , contentSlideContent :: [Shape]

- }

- | TwoColumnSlide { twoColumnSlideHeader :: [ParaElem]

- , twoColumnSlideLeft :: [Shape]

- , twoColumnSlideRight :: [Shape]

- }

- deriving (Show, Eq)

-

-data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape

- deriving (Show, Eq)

-

-data Shape = Pic PicProps FilePath Text.Pandoc.Definition.Attr [ParaElem]

- | GraphicFrame [Graphic] [ParaElem]

- | TextBox [Paragraph]

- deriving (Show, Eq)

-

-type Cell = [Paragraph]

-

-data TableProps = TableProps { tblPrFirstRow :: Bool

- , tblPrBandRow :: Bool

- } deriving (Show, Eq)

-

-type ColWidth = Integer

-

-data Graphic = Tbl TableProps [ColWidth] [Cell] [[Cell]]

- deriving (Show, Eq)

-

-

-data Paragraph = Paragraph { paraProps :: ParaProps

- , paraElems :: [ParaElem]

- } deriving (Show, Eq)

-

-data HeaderType = TitleHeader | SlideHeader | InternalHeader Int

- deriving (Show, Eq)

-

-autoNumberingToType :: ListAttributes -> String

-autoNumberingToType (_, numStyle, numDelim) =

- typeString ++ delimString

- where

- typeString = case numStyle of

- Decimal -> "arabic"

- UpperAlpha -> "alphaUc"

- LowerAlpha -> "alphaLc"

- UpperRoman -> "romanUc"

- LowerRoman -> "romanLc"

- _ -> "arabic"

- delimString = case numDelim of

- Period -> "Period"

- OneParen -> "ParenR"

- TwoParens -> "ParenBoth"

- _ -> "Period"

-

-data BulletType = Bullet

- | AutoNumbering ListAttributes

- deriving (Show, Eq)

-

-data Algnment = AlgnLeft | AlgnRight | AlgnCenter

- deriving (Show, Eq)

-

-data ParaProps = ParaProps { pPropHeaderType :: Maybe HeaderType

- , pPropMarginLeft :: Maybe Pixels

- , pPropMarginRight :: Maybe Pixels

- , pPropLevel :: Int

- , pPropBullet :: Maybe BulletType

- , pPropAlign :: Maybe Algnment

- } deriving (Show, Eq)

-

-instance Default ParaProps where

- def = ParaProps { pPropHeaderType = Nothing

- , pPropMarginLeft = Just 0

- , pPropMarginRight = Just 0

- , pPropLevel = 0

- , pPropBullet = Nothing

- , pPropAlign = Nothing

- }

-

-newtype TeXString = TeXString {unTeXString :: String}

- deriving (Eq, Show)

-

-data ParaElem = Break

- | Run RunProps String

- -- It would be more elegant to have native TeXMath

- -- Expressions here, but this allows us to use

- -- `convertmath` from T.P.Writers.Math. Will perhaps

- -- revisit in the future.

- | MathElem MathType TeXString

- deriving (Show, Eq)

-

-data Strikethrough = NoStrike | SingleStrike | DoubleStrike

- deriving (Show, Eq)

-

-data Capitals = NoCapitals | SmallCapitals | AllCapitals

- deriving (Show, Eq)

-

-type URL = String

-

-data RunProps = RunProps { rPropBold :: Bool

- , rPropItalics :: Bool

- , rStrikethrough :: Maybe Strikethrough

- , rBaseline :: Maybe Int

- , rCap :: Maybe Capitals

- , rLink :: Maybe (URL, String)

- , rPropCode :: Bool

- , rPropBlockQuote :: Bool

- , rPropForceSize :: Maybe Pixels

- } deriving (Show, Eq)

-

-instance Default RunProps where

- def = RunProps { rPropBold = False

- , rPropItalics = False

- , rStrikethrough = Nothing

- , rBaseline = Nothing

- , rCap = Nothing

- , rLink = Nothing

- , rPropCode = False

- , rPropBlockQuote = False

- , rPropForceSize = Nothing

- }

-

-data PicProps = PicProps { picPropLink :: Maybe (URL, String)

- } deriving (Show, Eq)

-

-instance Default PicProps where

- def = PicProps { picPropLink = Nothing

- }

-

---------------------------------------------------

-

-inlinesToParElems :: Monad m => [Inline] -> P m [ParaElem]

-inlinesToParElems ils = concatMapM inlineToParElems ils

-

-inlineToParElems :: Monad m => Inline -> P m [ParaElem]

-inlineToParElems (Str s) = do

- pr <- asks envRunProps

- return [Run pr s]

-inlineToParElems (Emph ils) =

- local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $

- inlinesToParElems ils

-inlineToParElems (Strong ils) =

- local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $

- inlinesToParElems ils

-inlineToParElems (Strikeout ils) =

- local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $

- inlinesToParElems ils

-inlineToParElems (Superscript ils) =

- local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $

- inlinesToParElems ils

-inlineToParElems (Subscript ils) =

- local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $

- inlinesToParElems ils

-inlineToParElems (SmallCaps ils) =

- local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $

- inlinesToParElems ils

-inlineToParElems Space = inlineToParElems (Str " ")

-inlineToParElems SoftBreak = inlineToParElems (Str " ")

-inlineToParElems LineBreak = return [Break]

-inlineToParElems (Link _ ils (url, title)) = do

- local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $

- inlinesToParElems ils

-inlineToParElems (Code _ str) = do

- local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $

- inlineToParElems $ Str str

-inlineToParElems (Math mathtype str) =

- return [MathElem mathtype (TeXString str)]

-inlineToParElems (Note blks) = do

- notes <- gets stNoteIds

- let maxNoteId = case M.keys notes of

- [] -> 0

- lst -> maximum lst

- curNoteId = maxNoteId + 1

- modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes }

- inlineToParElems $ Superscript [Str $ show curNoteId]

-inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils

-inlineToParElems (RawInline _ _) = return []

-inlineToParElems _ = return []

-

-isListType :: Block -> Bool

-isListType (OrderedList _ _) = True

-isListType (BulletList _) = True

-isListType (DefinitionList _) = True

-isListType _ = False

-

-blockToParagraphs :: PandocMonad m => Block -> P m [Paragraph]

-blockToParagraphs (Plain ils) = do

- parElems <- inlinesToParElems ils

- pProps <- asks envParaProps

- return [Paragraph pProps parElems]

-blockToParagraphs (Para ils) = do

- parElems <- inlinesToParElems ils

- pProps <- asks envParaProps

- return [Paragraph pProps parElems]

-blockToParagraphs (LineBlock ilsList) = do

- parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList

- pProps <- asks envParaProps

- return [Paragraph pProps parElems]

--- TODO: work out the attributes

-blockToParagraphs (CodeBlock attr str) =

- local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $

- blockToParagraphs $ Para [Code attr str]

--- We can't yet do incremental lists, but we should render a

--- (BlockQuote List) as a list to maintain compatibility with other

--- formats.

-blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do

- ps <- blockToParagraphs blk

- ps' <- blockToParagraphs $ BlockQuote blks

- return $ ps ++ ps'

-blockToParagraphs (BlockQuote blks) =

- local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100}

- , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$

- concatMapM blockToParagraphs blks

--- TODO: work out the format

-blockToParagraphs (RawBlock _ _) = return []

-blockToParagraphs (Header n _ ils) = do

- slideLevel <- asks envSlideLevel

- parElems <- inlinesToParElems ils

- -- For the time being we're not doing headers inside of bullets, but

- -- we might change that.

- let headerType = case n `compare` slideLevel of

- LT -> TitleHeader

- EQ -> SlideHeader

- GT -> InternalHeader (n - slideLevel)

- return [Paragraph def{pPropHeaderType = Just headerType} parElems]

-blockToParagraphs (BulletList blksLst) = do

- pProps <- asks envParaProps

- let lvl = pPropLevel pProps

- local (\env -> env{ envInList = True

- , envParaProps = pProps{ pPropLevel = lvl + 1

- , pPropBullet = Just Bullet

- , pPropMarginLeft = Nothing

- }}) $

- concatMapM multiParBullet blksLst

-blockToParagraphs (OrderedList listAttr blksLst) = do

- pProps <- asks envParaProps

- let lvl = pPropLevel pProps

- local (\env -> env{ envInList = True

- , envParaProps = pProps{ pPropLevel = lvl + 1

- , pPropBullet = Just (AutoNumbering listAttr)

- , pPropMarginLeft = Nothing

- }}) $

- concatMapM multiParBullet blksLst

-blockToParagraphs (DefinitionList entries) = do

- let go :: PandocMonad m => ([Inline], [[Block]]) -> P m [Paragraph]

- go (ils, blksLst) = do

- term <-blockToParagraphs $ Para [Strong ils]

- -- For now, we'll treat each definition term as a

- -- blockquote. We can extend this further later.

- definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst

- return $ term ++ definition

- concatMapM go entries

-blockToParagraphs (Div (_, ("notes" : []), _) _) = return []

-blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks

-blockToParagraphs blk = do

- P.report $ BlockNotRendered blk

- return []

-

--- Make sure the bullet env gets turned off after the first para.

-multiParBullet :: PandocMonad m => [Block] -> P m [Paragraph]

-multiParBullet [] = return []

-multiParBullet (b:bs) = do

- pProps <- asks envParaProps

- p <- blockToParagraphs b

- ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $

- concatMapM blockToParagraphs bs

- return $ p ++ ps

-

-cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> P m [Paragraph]

-cellToParagraphs algn tblCell = do

- paras <- mapM (blockToParagraphs) tblCell

- let alignment = case algn of

- AlignLeft -> Just AlgnLeft

- AlignRight -> Just AlgnRight

- AlignCenter -> Just AlgnCenter

- AlignDefault -> Nothing

- paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras

- return $ concat paras'

-

-rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> P m [[Paragraph]]

-rowToParagraphs algns tblCells = do

- -- We have to make sure we have the right number of alignments

- let pairs = zip (algns ++ repeat AlignDefault) tblCells

- mapM (\(a, tc) -> cellToParagraphs a tc) pairs

-

-blockToShape :: PandocMonad m => Block -> P m Shape

-blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il =

- Pic def url attr <$> (inlinesToParElems ils)

-blockToShape (Para (il:_)) | Image attr ils (url, _) <- il =

- Pic def url attr <$> (inlinesToParElems ils)

-blockToShape (Plain (il:_)) | Link _ (il':_) target <- il

- , Image attr ils (url, _) <- il' =

- Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)

-blockToShape (Para (il:_)) | Link _ (il':_) target <- il

- , Image attr ils (url, _) <- il' =

- Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)

-blockToShape (Table caption algn _ hdrCells rows) = do

- caption' <- inlinesToParElems caption

- pageWidth <- presSizeWidth <$> asks envPresentationSize

- hdrCells' <- rowToParagraphs algn hdrCells

- rows' <- mapM (rowToParagraphs algn) rows

- let tblPr = if null hdrCells

- then TableProps { tblPrFirstRow = False

- , tblPrBandRow = True

- }

- else TableProps { tblPrFirstRow = True

- , tblPrBandRow = True

- }

- colWidths = if null hdrCells

- then case rows of

- r : _ | not (null r) -> replicate (length r) $

- (pageWidth - (2 * hardcodedTableMargin))`div` (toInteger $ length r)

- -- satisfy the compiler. This is the same as

- -- saying that rows is empty, but the compiler

- -- won't understand that `[]` exhausts the

- -- alternatives.

- _ -> []

- else replicate (length hdrCells) $

- (pageWidth - (2 * hardcodedTableMargin)) `div` (toInteger $ length hdrCells)

-

- return $ GraphicFrame [Tbl tblPr colWidths hdrCells' rows'] caption'

-blockToShape blk = TextBox <$> blockToParagraphs blk

-

-blocksToShapes :: PandocMonad m => [Block] -> P m [Shape]

-blocksToShapes blks = combineShapes <$> mapM blockToShape blks

-

-isImage :: Inline -> Bool

-isImage (Image _ _ _) = True

-isImage (Link _ ((Image _ _ _) : _) _) = True

-isImage _ = False

-

-splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> P m [[Block]]

-splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur])

-splitBlocks' cur acc (HorizontalRule : blks) =

- splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks

-splitBlocks' cur acc (h@(Header n _ _) : blks) = do

- slideLevel <- asks envSlideLevel

- case compare n slideLevel of

- LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks

- EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks

- GT -> splitBlocks' (cur ++ [h]) acc blks

--- `blockToParagraphs` treats Plain and Para the same, so we can save

--- some code duplication by treating them the same here.

-splitBlocks' cur acc ((Plain ils) : blks) = splitBlocks' cur acc ((Para ils) : blks)

-splitBlocks' cur acc ((Para (il:ils)) : blks) | isImage il = do

- slideLevel <- asks envSlideLevel

- case cur of

- (Header n _ _) : [] | n == slideLevel ->

- splitBlocks' []

- (acc ++ [cur ++ [Para [il]]])

- (if null ils then blks else (Para ils) : blks)

- _ -> splitBlocks' []

- (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]])

- (if null ils then blks else (Para ils) : blks)

-splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do

- slideLevel <- asks envSlideLevel

- case cur of

- (Header n _ _) : [] | n == slideLevel ->

- splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks

- _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks

-splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do

- slideLevel <- asks envSlideLevel

- case cur of

- (Header n _ _) : [] | n == slideLevel ->

- splitBlocks' [] (acc ++ [cur ++ [d]]) blks

- _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks

-splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks

-

-splitBlocks :: Monad m => [Block] -> P m [[Block]]

-splitBlocks = splitBlocks' [] []

-

-blocksToSlide' :: PandocMonad m => Int -> [Block] -> P m Slide

-blocksToSlide' lvl ((Header n _ ils) : blks)

- | n < lvl = do

- hdr <- inlinesToParElems ils

- return $ TitleSlide {titleSlideHeader = hdr}

- | n == lvl = do

- hdr <- inlinesToParElems ils

- -- Now get the slide without the header, and then add the header

- -- in.

- slide <- blocksToSlide' lvl blks

- return $ case slide of

- ContentSlide _ cont -> ContentSlide hdr cont

- TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR

- slide' -> slide'

-blocksToSlide' _ (blk : blks)

- | Div (_, classes, _) divBlks <- blk

- , "columns" `elem` classes

- , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks

- , "column" `elem` clsL, "column" `elem` clsR = do

- unless (null blks)

- (mapM (P.report . BlockNotRendered) blks >> return ())

- unless (null remaining)

- (mapM (P.report . BlockNotRendered) remaining >> return ())

- shapesL <- blocksToShapes blksL

- shapesR <- blocksToShapes blksR

- return $ TwoColumnSlide { twoColumnSlideHeader = []

- , twoColumnSlideLeft = shapesL

- , twoColumnSlideRight = shapesR

- }

-blocksToSlide' _ (blk : blks) = do

- inNoteSlide <- asks envInNoteSlide

- shapes <- if inNoteSlide

- then forceFontSize noteSize $ blocksToShapes (blk : blks)

- else blocksToShapes (blk : blks)

- return $ ContentSlide { contentSlideHeader = []

- , contentSlideContent = shapes

- }

-blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = []

- , contentSlideContent = []

- }

-

-blocksToSlide :: PandocMonad m => [Block] -> P m Slide

-blocksToSlide blks = do

- slideLevel <- asks envSlideLevel

- blocksToSlide' slideLevel blks

-

-makeNoteEntry :: Int -> [Block] -> [Block]

-makeNoteEntry n blks =

- let enum = Str (show n ++ ".")

- in

- case blks of

- (Para ils : blks') -> (Para $ enum : Space : ils) : blks'

- _ -> (Para [enum]) : blks

-

-forceFontSize :: PandocMonad m => Pixels -> P m a -> P m a

-forceFontSize px x = do

- rpr <- asks envRunProps

- local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x

-

--- Right now, there's no logic for making more than one slide, but I

--- want to leave the option open to make multiple slides if we figure

--- out how to guess at how much space the text of the notes will take

--- up (or if we allow a way for it to be manually controlled). Plus a

--- list will make it easier to put together in the final

--- `blocksToPresentation` function (since we can just add an empty

--- list without checking the state).

-makeNotesSlides :: PandocMonad m => P m [Slide]

-makeNotesSlides = local (\env -> env{envInNoteSlide=True}) $ do

- noteIds <- gets stNoteIds

- if M.null noteIds

- then return []

- else do let hdr = Header 2 nullAttr [Str "Notes"]

- blks <- return $

- concatMap (\(n, bs) -> makeNoteEntry n bs) $

- M.toList noteIds

- sld <- blocksToSlide $ hdr : blks

- return [sld]

-

-getMetaSlide :: PandocMonad m => P m (Maybe Slide)

-getMetaSlide = do

- meta <- asks envMetadata

- title <- inlinesToParElems $ docTitle meta

- subtitle <- inlinesToParElems $

- case lookupMeta "subtitle" meta of

- Just (MetaString s) -> [Str s]

- Just (MetaInlines ils) -> ils

- Just (MetaBlocks [Plain ils]) -> ils

- Just (MetaBlocks [Para ils]) -> ils

- _ -> []

- authors <- mapM inlinesToParElems $ docAuthors meta

- date <- inlinesToParElems $ docDate meta

- if null title && null subtitle && null authors && null date

- then return Nothing

- else return $ Just $ MetadataSlide { metadataSlideTitle = title

- , metadataSlideSubtitle = subtitle

- , metadataSlideAuthors = authors

- , metadataSlideDate = date

- }

-

-blocksToPresentation :: PandocMonad m => [Block] -> P m Presentation

-blocksToPresentation blks = do

- blksLst <- splitBlocks blks

- slides <- mapM blocksToSlide blksLst

- noteSlides <- makeNotesSlides

- let slides' = slides ++ noteSlides

- metadataslide <- getMetaSlide

- presSize <- asks envPresentationSize

- return $ case metadataslide of

- Just metadataslide' -> Presentation presSize $ metadataslide' : slides'

- Nothing -> Presentation presSize slides'

-

---------------------------------------------------------------------

-

-copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive

-copyFileToArchive arch fp = do

- refArchive <- asks envRefArchive

- distArchive <- asks envDistArchive

- case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of

- Nothing -> fail $ fp ++ " missing in reference file"

- Just e -> return $ addEntryToArchive e arch

-

-getMediaFiles :: PandocMonad m => P m [FilePath]

-getMediaFiles = do

- refArchive <- asks envRefArchive

- distArchive <- asks envDistArchive

- let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive

- return $ filter (isPrefixOf "ppt/media") allEntries

-

-

-copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive

-copyFileToArchiveIfExists arch fp = do

- refArchive <- asks envRefArchive

- distArchive <- asks envDistArchive

- case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of

- Nothing -> return $ arch

- Just e -> return $ addEntryToArchive e arch

-

-inheritedFiles :: [FilePath]

-inheritedFiles = [ "_rels/.rels"

- , "docProps/app.xml"

- , "docProps/core.xml"

- , "ppt/slideLayouts/slideLayout4.xml"

- , "ppt/slideLayouts/_rels/slideLayout9.xml.rels"

- , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"

- , "ppt/slideLayouts/_rels/slideLayout10.xml.rels"

- , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"

- , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"

- , "ppt/slideLayouts/_rels/slideLayout5.xml.rels"

- , "ppt/slideLayouts/_rels/slideLayout7.xml.rels"

- , "ppt/slideLayouts/_rels/slideLayout8.xml.rels"

- , "ppt/slideLayouts/_rels/slideLayout11.xml.rels"

- , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"

- , "ppt/slideLayouts/_rels/slideLayout6.xml.rels"

- , "ppt/slideLayouts/slideLayout2.xml"

- , "ppt/slideLayouts/slideLayout8.xml"

- , "ppt/slideLayouts/slideLayout11.xml"

- , "ppt/slideLayouts/slideLayout3.xml"

- , "ppt/slideLayouts/slideLayout6.xml"

- , "ppt/slideLayouts/slideLayout9.xml"

- , "ppt/slideLayouts/slideLayout5.xml"

- , "ppt/slideLayouts/slideLayout7.xml"

- , "ppt/slideLayouts/slideLayout1.xml"

- , "ppt/slideLayouts/slideLayout10.xml"

- -- , "ppt/_rels/presentation.xml.rels"

- , "ppt/theme/theme1.xml"

- , "ppt/presProps.xml"

- -- , "ppt/slides/_rels/slide1.xml.rels"

- -- , "ppt/slides/_rels/slide2.xml.rels"

- -- This is the one we're

- -- going to build

- -- , "ppt/slides/slide2.xml"

- -- , "ppt/slides/slide1.xml"

- , "ppt/viewProps.xml"

- , "ppt/tableStyles.xml"

- , "ppt/slideMasters/_rels/slideMaster1.xml.rels"

- , "ppt/slideMasters/slideMaster1.xml"

- -- , "ppt/presentation.xml"

- -- , "[Content_Types].xml"

- ]

-

--- Here are some that might not be there. We won't fail if they're not

-possibleInheritedFiles :: [FilePath]

-possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ]

-

-presentationToArchive :: PandocMonad m => Presentation -> P m Archive

-presentationToArchive p@(Presentation _ slides) = do

- newArch <- foldM copyFileToArchive emptyArchive inheritedFiles

- mediaDir <- getMediaFiles

- newArch' <- foldM copyFileToArchiveIfExists newArch $

- possibleInheritedFiles ++ mediaDir

- -- presentation entry and rels. We have to do the rels first to make

- -- sure we know the correct offset for the rIds.

- presEntry <- presentationToPresEntry p

- presRelsEntry <- presentationToRelsEntry p

- slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..]

- slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..]

- -- These have to come after everything, because they need the info

- -- built up in the state.

- mediaEntries <- makeMediaEntries

- contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry

- -- fold everything into our inherited archive and return it.

- return $ foldr addEntryToArchive newArch' $

- slideEntries ++

- slideRelEntries ++

- mediaEntries ++

- [contentTypesEntry, presEntry, presRelsEntry]

-

---------------------------------------------------

-

-combineShapes :: [Shape] -> [Shape]

-combineShapes [] = []

-combineShapes (s : []) = [s]

-combineShapes (pic@(Pic _ _ _ _) : ss) = pic : combineShapes ss

-combineShapes ((TextBox []) : ss) = combineShapes ss

-combineShapes (s : TextBox [] : ss) = combineShapes (s : ss)

-combineShapes (s@(TextBox (p:ps)) : s'@(TextBox (p':ps')) : ss)

- | pPropHeaderType (paraProps p) == Just TitleHeader ||

- pPropHeaderType (paraProps p) == Just SlideHeader =

- TextBox [p] : (combineShapes $ TextBox ps : s' : ss)

- | pPropHeaderType (paraProps p') == Just TitleHeader ||

- pPropHeaderType (paraProps p') == Just SlideHeader =

- s : TextBox [p'] : (combineShapes $ TextBox ps' : ss)

- | otherwise = combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss

-combineShapes (s:ss) = s : combineShapes ss

-

---------------------------------------------------

-

-getLayout :: PandocMonad m => Slide -> P m Element

-getLayout slide = do

- let layoutpath = case slide of

- (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml"

- (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml"

- (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml"

- (TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.xml"

- distArchive <- asks envDistArchive

- root <- case findEntryByPath layoutpath distArchive of

- Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of

- Just element -> return $ element

- Nothing -> throwError $

- PandocSomeError $

- layoutpath ++ " corrupt in reference file"

- Nothing -> throwError $

- PandocSomeError $

- layoutpath ++ " missing in reference file"

- return root

-

-shapeHasName :: NameSpaces -> String -> Element -> Bool

-shapeHasName ns name element

- | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element

- , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr

- , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr =

- nm == name

- | otherwise = False

-

-getContentShape :: NameSpaces -> Element -> Maybe Element

-getContentShape ns spTreeElem

- | isElem ns "p" "spTree" spTreeElem =

- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Content Placeholder 2" e)) spTreeElem

- | otherwise = Nothing

-

-replaceNamedChildren :: NameSpaces

- -> String

- -> String

- -> [Element]

- -> Element

- -> Element

-replaceNamedChildren ns prefix name newKids element =

- element { elContent = concat $ fun True $ elContent element }

- where

- fun :: Bool -> [Content] -> [[Content]]

- fun _ [] = []

- fun switch ((Elem e) : conts) | isElem ns prefix name e =

- if switch

- then (map Elem $ newKids) : fun False conts

- else fun False conts

- fun switch (cont : conts) = [cont] : fun switch conts

-

-----------------------------------------------------------------

-

-registerLink :: PandocMonad m => (URL, String) -> P m Int

-registerLink link = do

- curSlideId <- gets stCurSlideId

- linkReg <- gets stLinkIds

- mediaReg <- gets stMediaIds

- let maxLinkId = case M.lookup curSlideId linkReg of

- Just mp -> case M.keys mp of

- [] -> 1

- ks -> maximum ks

- Nothing -> 1

- maxMediaId = case M.lookup curSlideId mediaReg of

- Just [] -> 1

- Just mInfos -> maximum $ map mInfoLocalId mInfos

- Nothing -> 1

- maxId = max maxLinkId maxMediaId

- slideLinks = case M.lookup curSlideId linkReg of

- Just mp -> M.insert (maxId + 1) link mp

- Nothing -> M.singleton (maxId + 1) link

- modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg}

- return $ maxId + 1

-

-registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo

-registerMedia fp caption = do

- curSlideId <- gets stCurSlideId

- linkReg <- gets stLinkIds

- mediaReg <- gets stMediaIds

- globalIds <- gets stMediaGlobalIds

- let maxLinkId = case M.lookup curSlideId linkReg of

- Just mp -> case M.keys mp of

- [] -> 1

- ks -> maximum ks

- Nothing -> 1

- maxMediaId = case M.lookup curSlideId mediaReg of

- Just [] -> 1

- Just mInfos -> maximum $ map mInfoLocalId mInfos

- Nothing -> 1

- maxLocalId = max maxLinkId maxMediaId

-

- maxGlobalId = case M.elems globalIds of

- [] -> 0

- ids -> maximum ids

-

- (imgBytes, mbMt) <- P.fetchItem fp

- let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x))

- <|>

- case imageType imgBytes of

- Just Png -> Just ".png"

- Just Jpeg -> Just ".jpeg"

- Just Gif -> Just ".gif"

- Just Pdf -> Just ".pdf"

- Just Eps -> Just ".eps"

- Just Svg -> Just ".svg"

- Nothing -> Nothing

-

- let newGlobalId = case M.lookup fp globalIds of

- Just ident -> ident

- Nothing -> maxGlobalId + 1

-

- let newGlobalIds = M.insert fp newGlobalId globalIds

-

- let mediaInfo = MediaInfo { mInfoFilePath = fp

- , mInfoLocalId = maxLocalId + 1

- , mInfoGlobalId = newGlobalId

- , mInfoMimeType = mbMt

- , mInfoExt = imgExt

- , mInfoCaption = (not . null) caption

- }

-

- let slideMediaInfos = case M.lookup curSlideId mediaReg of

- Just minfos -> mediaInfo : minfos

- Nothing -> [mediaInfo]

-

-

- modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg

- , stMediaGlobalIds = newGlobalIds

- }

- return mediaInfo

-

-makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry

-makeMediaEntry mInfo = do

- epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime

- (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)

- let ext = case mInfoExt mInfo of

- Just e -> e

- Nothing -> ""

- let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext

- return $ toEntry fp epochtime $ BL.fromStrict imgBytes

-

-makeMediaEntries :: PandocMonad m => P m [Entry]

-makeMediaEntries = do

- mediaInfos <- gets stMediaIds

- let allInfos = mconcat $ M.elems mediaInfos

- mapM makeMediaEntry allInfos

-

--- | Scales the image to fit the page

--- sizes are passed in emu

-fitToPage' :: (Double, Double) -- image size in emu

- -> Integer -- pageWidth

- -> Integer -- pageHeight

- -> (Integer, Integer) -- imagesize

-fitToPage' (x, y) pageWidth pageHeight

- -- Fixes width to the page width and scales the height

- | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight =

- (floor x, floor y)

- | x / fromIntegral pageWidth > y / fromIntegral pageWidth =

- (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y)

- | otherwise =

- (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight)

-

-positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer)

-positionImage (x, y) pageWidth pageHeight =

- let (x', y') = fitToPage' (x, y) pageWidth pageHeight

- in

- ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2)

-

-getMaster :: PandocMonad m => P m Element

-getMaster = do

- refArchive <- asks envRefArchive

- distArchive <- asks envDistArchive

- parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml"

-

--- We want to get the header dimensions, so we can make sure that the

--- image goes underneath it. We only use this in a content slide if it

--- has a header.

-

-getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer))

-getHeaderSize = do

- master <- getMaster

- let ns = elemToNameSpaces master

- sps = [master] >>=

- findChildren (elemName ns "p" "cSld") >>=

- findChildren (elemName ns "p" "spTree") >>=

- findChildren (elemName ns "p" "sp")

- mbXfrm =

- listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>=

- findChild (elemName ns "p" "spPr") >>=

- findChild (elemName ns "a" "xfrm")

- xoff = mbXfrm >>=

- findChild (elemName ns "a" "off") >>=

- findAttr (QName "x" Nothing Nothing) >>=

- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

- yoff = mbXfrm >>=

- findChild (elemName ns "a" "off") >>=

- findAttr (QName "y" Nothing Nothing) >>=

- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

- xext = mbXfrm >>=

- findChild (elemName ns "a" "ext") >>=

- findAttr (QName "cx" Nothing Nothing) >>=

- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

- yext = mbXfrm >>=

- findChild (elemName ns "a" "ext") >>=

- findAttr (QName "cy" Nothing Nothing) >>=

- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

- off = case xoff of

- Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff')

- _ -> (1043490, 1027664)

- ext = case xext of

- Just (xext', _) | Just (yext',_) <- yext -> (xext', yext')

- _ -> (7024744, 1143000)

- return $ (off, ext)

-

-

--- Hard-coded for now

-captionPosition :: ((Integer, Integer), (Integer, Integer))

-captionPosition = ((457200, 6061972), (8229600, 527087))

-

-createCaption :: PandocMonad m => [ParaElem] -> P m Element

-createCaption paraElements = do

- let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements

- elements <- mapM paragraphToElement [para]

- let ((x, y), (cx, cy)) = captionPosition

- let txBody = mknode "p:txBody" [] $

- [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements

- return $

- mknode "p:sp" [] [ mknode "p:nvSpPr" []

- [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] ()

- , mknode "p:cNvSpPr" [("txBox", "1")] ()

- , mknode "p:nvPr" [] ()

- ]

- , mknode "p:spPr" []

- [ mknode "a:xfrm" []

- [ mknode "a:off" [("x", show x), ("y", show y)] ()

- , mknode "a:ext" [("cx", show cx), ("cy", show cy)] ()

- ]

- , mknode "a:prstGeom" [("prst", "rect")]

- [ mknode "a:avLst" [] ()

- ]

- , mknode "a:noFill" [] ()

- ]

- , txBody

- ]

-

--- Largely lifted from inlineToOpenXML' in T.P.W.Docx. Can't be easily

--- abstracted because of some different namespaces and monads. TODO.

-makePicElement :: PandocMonad m

- => PicProps

- -> MediaInfo

- -> Text.Pandoc.Definition.Attr

- -> P m Element

-makePicElement picProps mInfo attr = do

- opts <- asks envOpts

- pageWidth <- presSizeWidth <$> asks envPresentationSize

- pageHeight <- getPageHeight <$> asks envPresentationSize

- hasHeader <- asks envSlideHasHeader

- let hasCaption = mInfoCaption mInfo

- (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)

- -- We're not using x exts

- ((hXoff, hYoff), (_, hYext)) <- if hasHeader

- then getHeaderSize

- else return ((0, 0), (0, 0))

-

- let ((capX, capY), (_, _)) = if hasCaption

- then captionPosition

- else ((0,0), (0,0))

- let (xpt,ypt) = desiredSizeInPoints opts attr

- (either (const def) id (imageSize opts imgBytes))

- -- 12700 emu = 1 pt

- let (xemu,yemu) = fitToPage' (xpt * 12700, ypt * 12700)

- ((pageWidth * 12700) - (2 * hXoff) - (2 * capX))

- ((if hasCaption then capY else (pageHeight * 12700)) - (hYoff + hYext))

- (xoff, yoff) = positionImage (xpt * 12700, ypt * 12700) (pageWidth * 12700) (pageHeight * 12700)

- xoff' = if hasHeader then xoff + hXoff else xoff

- xoff'' = if hasCaption then xoff' + capX else xoff'

- yoff' = if hasHeader then hYoff + hYext else yoff

- let cNvPicPr = mknode "p:cNvPicPr" [] $

- mknode "a:picLocks" [("noGrp","1")

- ,("noChangeAspect","1")] ()

- -- cNvPr will contain the link information so we do that separately,

- -- and register the link if necessary.

- let cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")]

- cNvPr <- case picPropLink picProps of

- Just link -> do idNum <- registerLink link

- return $ mknode "p:cNvPr" cNvPrAttr $

- mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] ()

- Nothing -> return $ mknode "p:cNvPr" cNvPrAttr ()

- let nvPicPr = mknode "p:nvPicPr" []

- [ cNvPr

- , cNvPicPr

- , mknode "p:nvPr" [] ()]

- let blipFill = mknode "p:blipFill" []

- [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] ()

- , mknode "a:stretch" [] $

- mknode "a:fillRect" [] () ]

- let xfrm = mknode "a:xfrm" []

- [ mknode "a:off" [("x",show xoff''), ("y",show yoff')] ()

- , mknode "a:ext" [("cx",show xemu)

- ,("cy",show yemu)] () ]

- let prstGeom = mknode "a:prstGeom" [("prst","rect")] $

- mknode "a:avLst" [] ()

- let ln = mknode "a:ln" [("w","9525")]

- [ mknode "a:noFill" [] ()

- , mknode "a:headEnd" [] ()

- , mknode "a:tailEnd" [] () ]

- let spPr = mknode "p:spPr" [("bwMode","auto")]

- [xfrm, prstGeom, mknode "a:noFill" [] (), ln]

- return $

- mknode "p:pic" []

- [ nvPicPr

- , blipFill

- , spPr ]

-

--- Currently hardcoded, until I figure out how to make it dynamic.

-blockQuoteSize :: Pixels

-blockQuoteSize = 20

-

-noteSize :: Pixels

-noteSize = 18

-

-paraElemToElement :: PandocMonad m => ParaElem -> P m Element

-paraElemToElement Break = return $ mknode "a:br" [] ()

-paraElemToElement (Run rpr s) = do

- let sizeAttrs = case rPropForceSize rpr of

- Just n -> [("sz", (show $ n * 100))]

- Nothing -> []

- attrs = sizeAttrs ++

- if rPropCode rpr

- then []

- else (if rPropBold rpr then [("b", "1")] else []) ++

- (if rPropItalics rpr then [("i", "1")] else []) ++

- (case rStrikethrough rpr of

- Just NoStrike -> [("strike", "noStrike")]

- Just SingleStrike -> [("strike", "sngStrike")]

- Just DoubleStrike -> [("strike", "dblStrike")]

- Nothing -> []) ++

- (case rBaseline rpr of

- Just n -> [("baseline", show n)]

- Nothing -> []) ++

- (case rCap rpr of

- Just NoCapitals -> [("cap", "none")]

- Just SmallCapitals -> [("cap", "small")]

- Just AllCapitals -> [("cap", "all")]

- Nothing -> []) ++

- []

- linkProps <- case rLink rpr of

- Just link -> do idNum <- registerLink link

- return [mknode "a:hlinkClick"

- [("r:id", "rId" ++ show idNum)]

- ()

- ]

- Nothing -> return []

- let propContents = if rPropCode rpr

- then [mknode "a:latin" [("typeface", "Courier")] ()]

- else linkProps

- return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents

- , mknode "a:t" [] s

- ]

-paraElemToElement (MathElem mathType texStr) = do

- res <- convertMath writeOMML mathType (unTeXString texStr)

- case res of

- Right r -> return $ mknode "a14:m" [] $ addMathInfo r

- Left (Str s) -> paraElemToElement (Run def s)

- Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback"

-

--- This is a bit of a kludge -- really requires adding an option to

--- TeXMath, but since that's a different package, we'll do this one

--- step at a time.

-addMathInfo :: Element -> Element

-addMathInfo element =

- let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns"))

- , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"

- }

- in add_attr mathspace element

-

--- We look through the element to see if it contains an a14:m

--- element. If so, we surround it. This is a bit ugly, but it seems

--- more dependable than looking through shapes for math. Plus this is

--- an xml implementation detail, so it seems to make sense to do it at

--- the xml level.

-surroundWithMathAlternate :: Element -> Element

-surroundWithMathAlternate element =

- case findElement (QName "m" Nothing (Just "a14")) element of

- Just _ ->

- mknode "mc:AlternateContent"

- [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")

- ] [ mknode "mc:Choice"

- [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main")

- , ("Requires", "a14")] [ element ]

- ]

- Nothing -> element

-

-paragraphToElement :: PandocMonad m => Paragraph -> P m Element

-paragraphToElement par = do

- let

- attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++

- (case pPropMarginLeft (paraProps par) of

- Just px -> [("marL", show $ 12700 * px), ("indent", "0")]

- Nothing -> []

- ) ++

- (case pPropAlign (paraProps par) of

- Just AlgnLeft -> [("algn", "l")]

- Just AlgnRight -> [("algn", "r")]

- Just AlgnCenter -> [("algn", "ctr")]

- Nothing -> []

- )

- props = [] ++

- (case pPropBullet $ paraProps par of

- Just Bullet -> []

- Just (AutoNumbering attrs') ->

- [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()]

- Nothing -> [mknode "a:buNone" [] ()]

- )

- paras <- mapM paraElemToElement (combineParaElems $ paraElems par)

- return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras

-

-shapeToElement :: PandocMonad m => Element -> Shape -> P m Element

-shapeToElement layout (TextBox paras)

- | ns <- elemToNameSpaces layout

- , Just cSld <- findChild (elemName ns "p" "cSld") layout

- , Just spTree <- findChild (elemName ns "p" "spTree") cSld

- , Just sp <- getContentShape ns spTree = do

- elements <- mapM paragraphToElement paras

- let txBody = mknode "p:txBody" [] $

- [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements

- emptySpPr = mknode "p:spPr" [] ()

- return $

- surroundWithMathAlternate $

- replaceNamedChildren ns "p" "txBody" [txBody] $

- replaceNamedChildren ns "p" "spPr" [emptySpPr] $

- sp

- -- XXX: TODO

- | otherwise = return $ mknode "p:sp" [] ()

--- XXX: TODO

-shapeToElement layout (Pic picProps fp attr alt) = do

- mInfo <- registerMedia fp alt

- case mInfoExt mInfo of

- Just _ -> makePicElement picProps mInfo attr

- Nothing -> shapeToElement layout $ TextBox [Paragraph def alt]

-shapeToElement _ (GraphicFrame tbls _) = do

- elements <- mapM graphicToElement tbls

- return $ mknode "p:graphicFrame" [] $

- [ mknode "p:nvGraphicFramePr" [] $

- [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] ()

- , mknode "p:cNvGraphicFramePr" [] $

- [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()]

- , mknode "p:nvPr" [] $

- [mknode "p:ph" [("idx", "1")] ()]

- ]

- , mknode "p:xfrm" [] $

- [ mknode "a:off" [("x", "457200"), ("y", "1600200")] ()

- , mknode "a:ext" [("cx", "8029388"), ("cy", "3644152")] ()

- ]

- ] ++ elements

-

-shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element]

-shapeToElements layout shp = do

- case shp of

- (Pic _ _ _ alt) | (not . null) alt -> do

- element <- shapeToElement layout shp

- caption <- createCaption alt

- return [element, caption]

- (GraphicFrame _ cptn) | (not . null) cptn -> do

- element <- shapeToElement layout shp

- caption <- createCaption cptn

- return [element, caption]

- _ -> do

- element <- shapeToElement layout shp

- return [element]

-

-shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element]

-shapesToElements layout shps = do

- concat <$> mapM (shapeToElements layout) shps

-

-hardcodedTableMargin :: Integer

-hardcodedTableMargin = 36

-

-

-graphicToElement :: PandocMonad m => Graphic -> P m Element

-graphicToElement (Tbl tblPr colWidths hdrCells rows) = do

- let cellToOpenXML paras =

- do elements <- mapM paragraphToElement paras

- let elements' = if null elements

- then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]]

- else elements

- return $

- [mknode "a:txBody" [] $

- ([ mknode "a:bodyPr" [] ()

- , mknode "a:lstStyle" [] ()]

- ++ elements')]

- headers' <- mapM cellToOpenXML hdrCells

- rows' <- mapM (mapM cellToOpenXML) rows

- let borderProps = mknode "a:tcPr" [] ()

- let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]]

- let mkcell border contents = mknode "a:tc" []

- $ (if null contents

- then emptyCell

- else contents) ++ [ borderProps | border ]

- let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells

-

- let mkgridcol w = mknode "a:gridCol"

- [("w", show ((12700 * w) :: Integer))] ()

- let hasHeader = not (all null hdrCells)

- return $ mknode "a:graphic" [] $

- [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $

- [mknode "a:tbl" [] $

- [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0")

- , ("bandRow", if tblPrBandRow tblPr then "1" else "0")

- ] ()

- , mknode "a:tblGrid" [] (if all (==0) colWidths

- then []

- else map mkgridcol colWidths)

- ]

- ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows'

- ]

- ]

-

-getShapeByName :: NameSpaces -> Element -> String -> Maybe Element

-getShapeByName ns spTreeElem name

- | isElem ns "p" "spTree" spTreeElem =

- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem

- | otherwise = Nothing

-

-nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element

-nonBodyTextToElement layout shapeName paraElements

- | ns <- elemToNameSpaces layout

- , Just cSld <- findChild (elemName ns "p" "cSld") layout

- , Just spTree <- findChild (elemName ns "p" "spTree") cSld

- , Just sp <- getShapeByName ns spTree shapeName = do

- let hdrPara = Paragraph def paraElements

- element <- paragraphToElement hdrPara

- let txBody = mknode "p:txBody" [] $

- [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++

- [element]

- return $ replaceNamedChildren ns "p" "txBody" [txBody] sp

- -- XXX: TODO

- | otherwise = return $ mknode "p:sp" [] ()

-

-contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element

-contentToElement layout hdrShape shapes

- | ns <- elemToNameSpaces layout

- , Just cSld <- findChild (elemName ns "p" "cSld") layout

- , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

- element <- nonBodyTextToElement layout "Title 1" hdrShape

- let hdrShapeElements = if null hdrShape

- then []

- else [element]

- contentElements <- shapesToElements layout shapes

- return $

- replaceNamedChildren ns "p" "sp"

- (hdrShapeElements ++ contentElements)

- spTree

-contentToElement _ _ _ = return $ mknode "p:sp" [] ()

-

-setIdx'' :: NameSpaces -> String -> Content -> Content

-setIdx'' _ idx (Elem element) =

- let tag = XMLC.getTag element

- attrs = XMLC.tagAttribs tag

- idxKey = (QName "idx" Nothing Nothing)

- attrs' = Attr idxKey idx : (filter (\a -> attrKey a /= idxKey) attrs)

- tag' = tag {XMLC.tagAttribs = attrs'}

- in Elem $ XMLC.setTag tag' element

-setIdx'' _ _ c = c

-

-setIdx' :: NameSpaces -> String -> XMLC.Cursor -> XMLC.Cursor

-setIdx' ns idx cur =

- let modifiedCur = XMLC.modifyContent (setIdx'' ns idx) cur

- in

- case XMLC.nextDF modifiedCur of

- Just cur' -> setIdx' ns idx cur'

- Nothing -> XMLC.root modifiedCur

-

-setIdx :: NameSpaces -> String -> Element -> Element

-setIdx ns idx element =

- let cur = XMLC.fromContent (Elem element)

- cur' = setIdx' ns idx cur

- in

- case XMLC.toTree cur' of

- Elem element' -> element'

- _ -> element

-

-twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element

-twoColumnToElement layout hdrShape shapesL shapesR

- | ns <- elemToNameSpaces layout

- , Just cSld <- findChild (elemName ns "p" "cSld") layout

- , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

- element <- nonBodyTextToElement layout "Title 1" hdrShape

- let hdrShapeElements = if null hdrShape

- then []

- else [element]

- contentElementsL <- shapesToElements layout shapesL

- contentElementsR <- shapesToElements layout shapesR

- let contentElementsL' = map (setIdx ns "1") contentElementsL

- contentElementsR' = map (setIdx ns "2") contentElementsR

- return $

- replaceNamedChildren ns "p" "sp"

- (hdrShapeElements ++ contentElementsL' ++ contentElementsR')

- spTree

-twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] ()

-

-

-titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element

-titleToElement layout titleElems

- | ns <- elemToNameSpaces layout

- , Just cSld <- findChild (elemName ns "p" "cSld") layout

- , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

- element <- nonBodyTextToElement layout "Title 1" titleElems

- let titleShapeElements = if null titleElems

- then []

- else [element]

- return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree

-titleToElement _ _ = return $ mknode "p:sp" [] ()

-

-metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element

-metadataToElement layout titleElems subtitleElems authorsElems dateElems

- | ns <- elemToNameSpaces layout

- , Just cSld <- findChild (elemName ns "p" "cSld") layout

- , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

- titleShapeElements <- if null titleElems

- then return []

- else sequence [nonBodyTextToElement layout "Title 1" titleElems]

- let combinedAuthorElems = intercalate [Break] authorsElems

- subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems]

- subtitleShapeElements <- if null subtitleAndAuthorElems

- then return []

- else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems]

- dateShapeElements <- if null dateElems

- then return []

- else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems]

- return $ replaceNamedChildren ns "p" "sp"

- (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements)

- spTree

-metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] ()

-

-slideToElement :: PandocMonad m => Slide -> P m Element

-slideToElement s@(ContentSlide hdrElems shapes) = do

- layout <- getLayout s

- spTree <- local (\env -> if null hdrElems

- then env

- else env{envSlideHasHeader=True}) $

- contentToElement layout hdrElems shapes

- return $ mknode "p:sld"

- [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

- ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

- ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

- ] [mknode "p:cSld" [] [spTree]]

-slideToElement s@(TwoColumnSlide hdrElems shapesL shapesR) = do

- layout <- getLayout s

- spTree <- local (\env -> if null hdrElems

- then env

- else env{envSlideHasHeader=True}) $

- twoColumnToElement layout hdrElems shapesL shapesR

- return $ mknode "p:sld"

- [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

- ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

- ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

- ] [mknode "p:cSld" [] [spTree]]

-slideToElement s@(TitleSlide hdrElems) = do

- layout <- getLayout s

- spTree <- titleToElement layout hdrElems

- return $ mknode "p:sld"

- [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

- ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

- ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

- ] [mknode "p:cSld" [] [spTree]]

-slideToElement s@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do

- layout <- getLayout s

- spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems

- return $ mknode "p:sld"

- [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

- ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

- ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

- ] [mknode "p:cSld" [] [spTree]]

-

------------------------------------------------------------------------

-

-slideToFilePath :: Slide -> Int -> FilePath

-slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml"

-

-slideToSlideId :: Monad m => Slide -> Int -> P m String

-slideToSlideId _ idNum = do

- n <- gets stSlideIdOffset

- return $ "rId" ++ (show $ idNum + n)

-

-

-data Relationship = Relationship { relId :: Int

- , relType :: MimeType

- , relTarget :: FilePath

- } deriving (Show, Eq)

-

-elementToRel :: Element -> Maybe Relationship

-elementToRel element

- | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing =

- do rId <- findAttr (QName "Id" Nothing Nothing) element

- numStr <- stripPrefix "rId" rId

- num <- case reads numStr :: [(Int, String)] of

- (n, _) : _ -> Just n

- [] -> Nothing

- type' <- findAttr (QName "Type" Nothing Nothing) element

- target <- findAttr (QName "Target" Nothing Nothing) element

- return $ Relationship num type' target

- | otherwise = Nothing

-

-slideToPresRel :: Monad m => Slide -> Int -> P m Relationship

-slideToPresRel slide idNum = do

- n <- gets stSlideIdOffset

- let rId = idNum + n

- fp = "slides/" ++ slideToFilePath slide idNum

- return $ Relationship { relId = rId

- , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"

- , relTarget = fp

- }

-

-getRels :: PandocMonad m => P m [Relationship]

-getRels = do

- refArchive <- asks envRefArchive

- distArchive <- asks envDistArchive

- relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels"

- let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships"

- let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem

- return $ mapMaybe elementToRel relElems

-

-presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]

-presentationToRels (Presentation _ slides) = do

- mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..]

- rels <- getRels

- let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels

- -- We want to make room for the slides in the id space. The slides

- -- will start at Id2 (since Id1 is for the slide master). There are

- -- two slides in the data file, but that might change in the future,

- -- so we will do this:

- --

- -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is.

- -- 2. We add the difference between this and the number of slides to

- -- all relWithoutSlide rels (unless they're 1)

-

- let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of

- [] -> 0 -- doesn't matter in this case, since

- -- there will be nothing to map the

- -- function over

- l -> minimum l

-

- modifyRelNum :: Int -> Int

- modifyRelNum 1 = 1

- modifyRelNum n = n - minRelNotOne + 2 + length slides

-

- relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides

-

- return $ mySlideRels ++ relsWithoutSlides'

-

-relToElement :: Relationship -> Element

-relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel))

- , ("Type", relType rel)

- , ("Target", relTarget rel) ] ()

-

-relsToElement :: [Relationship] -> Element

-relsToElement rels = mknode "Relationships"

- [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]

- (map relToElement rels)

-

-presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry

-presentationToRelsEntry pres = do

- rels <- presentationToRels pres

- elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels

-

-elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry

-elemToEntry fp element = do

- epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime

- return $ toEntry fp epochtime $ renderXml element

-

-slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry

-slideToEntry slide idNum = do

- modify $ \st -> st{stCurSlideId = idNum}

- element <- slideToElement slide

- elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element

-

-slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry

-slideToSlideRelEntry slide idNum = do

- element <- slideToSlideRelElement slide idNum

- elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element

-

-linkRelElement :: Int -> (URL, String) -> Element

-linkRelElement idNum (url, _) =

- mknode "Relationship" [ ("Id", "rId" ++ show idNum)

- , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")

- , ("Target", url)

- , ("TargetMode", "External")

- ] ()

-

-linkRelElements :: M.Map Int (URL, String) -> [Element]

-linkRelElements mp = map (\(n, lnk) -> linkRelElement n lnk) (M.toList mp)

-

-mediaRelElement :: MediaInfo -> Element

-mediaRelElement mInfo =

- let ext = case mInfoExt mInfo of

- Just e -> e

- Nothing -> ""

- in

- mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo))

- , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")

- , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)

- ] ()

-

-slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element

-slideToSlideRelElement slide idNum = do

- let target = case slide of

- (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml"

- (TitleSlide _) -> "../slideLayouts/slideLayout3.xml"

- (ContentSlide _ _) -> "../slideLayouts/slideLayout2.xml"

- (TwoColumnSlide _ _ _) -> "../slideLayouts/slideLayout4.xml"

-

- linkIds <- gets stLinkIds

- mediaIds <- gets stMediaIds

-

- let linkRels = case M.lookup idNum linkIds of

- Just mp -> linkRelElements mp

- Nothing -> []

- mediaRels = case M.lookup idNum mediaIds of

- Just mInfos -> map mediaRelElement mInfos

- Nothing -> []

-

- return $

- mknode "Relationships"

- [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]

- ([mknode "Relationship" [ ("Id", "rId1")

- , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout")

- , ("Target", target)] ()

- ] ++ linkRels ++ mediaRels)

-

-slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element

-slideToSldIdElement slide idNum = do

- let id' = show $ idNum + 255

- rId <- slideToSlideId slide idNum

- return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()

-

-presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element

-presentationToSldIdLst (Presentation _ slides) = do

- ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..])

- return $ mknode "p:sldIdLst" [] ids

-

-presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element

-presentationToPresentationElement pres = do

- refArchive <- asks envRefArchive

- distArchive <- asks envDistArchive

- element <- parseXml refArchive distArchive "ppt/presentation.xml"

- sldIdLst <- presentationToSldIdLst pres

-

- let modifySldIdLst :: Content -> Content

- modifySldIdLst (Elem e) = case elName e of

- (QName "sldIdLst" _ _) -> Elem sldIdLst

- _ -> Elem e

- modifySldIdLst ct = ct

-

- newContent = map modifySldIdLst $ elContent element

-

- return $ element{elContent = newContent}

-

-presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry

-presentationToPresEntry pres = presentationToPresentationElement pres >>=

- elemToEntry "ppt/presentation.xml"

-

-

-

-

-defaultContentTypeToElem :: DefaultContentType -> Element

-defaultContentTypeToElem dct =

- mknode "Default"

- [("Extension", defContentTypesExt dct),

- ("ContentType", defContentTypesType dct)]

- ()

-

-overrideContentTypeToElem :: OverrideContentType -> Element

-overrideContentTypeToElem oct =

- mknode "Override"

- [("PartName", overrideContentTypesPart oct),

- ("ContentType", overrideContentTypesType oct)]

- ()

-

-contentTypesToElement :: ContentTypes -> Element

-contentTypesToElement ct =

- let ns = "http://schemas.openxmlformats.org/package/2006/content-types"

- in

- mknode "Types" [("xmlns", ns)] $

- (map defaultContentTypeToElem $ contentTypesDefaults ct) ++

- (map overrideContentTypeToElem $ contentTypesOverrides ct)

-

-data DefaultContentType = DefaultContentType

- { defContentTypesExt :: String

- , defContentTypesType:: MimeType

- }

- deriving (Show, Eq)

-

-data OverrideContentType = OverrideContentType

- { overrideContentTypesPart :: FilePath

- , overrideContentTypesType :: MimeType

- }

- deriving (Show, Eq)

-

-data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType]

- , contentTypesOverrides :: [OverrideContentType]

- }

- deriving (Show, Eq)

-

-contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry

-contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct

-

-pathToOverride :: FilePath -> Maybe OverrideContentType

-pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp)

-

-mediaContentType :: MediaInfo -> Maybe DefaultContentType

-mediaContentType mInfo

- | Just ('.' : ext) <- mInfoExt mInfo =

- Just $ DefaultContentType { defContentTypesExt = ext

- , defContentTypesType =

- case mInfoMimeType mInfo of

- Just mt -> mt

- Nothing -> "application/octet-stream"

- }

- | otherwise = Nothing

-

-presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes

-presentationToContentTypes (Presentation _ slides) = do

- mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds

- let defaults = [ DefaultContentType "xml" "application/xml"

- , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"

- ]

- mediaDefaults = nub $ mapMaybe mediaContentType mediaInfos

- inheritedOverrides = mapMaybe pathToOverride inheritedFiles

- presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]

- slideOverrides =

- mapMaybe

- (\(s, n) ->

- pathToOverride $ "ppt/slides/" ++ slideToFilePath s n)

- (zip slides [1..])

- -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"]

- return $ ContentTypes

- (defaults ++ mediaDefaults)

- (inheritedOverrides ++ presOverride ++ slideOverrides)

-

-presML :: String

-presML = "application/vnd.openxmlformats-officedocument.presentationml"

-

-noPresML :: String

-noPresML = "application/vnd.openxmlformats-officedocument"

-

-getContentType :: FilePath -> Maybe MimeType

-getContentType fp

- | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml"

- | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml"

- | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml"

- | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml"

- | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml"

- | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml"

- | "ppt" : "slideMasters" : f : [] <- splitDirectories fp

- , (_, ".xml") <- splitExtension f =

- Just $ presML ++ ".slideMaster+xml"

- | "ppt" : "slides" : f : [] <- splitDirectories fp

- , (_, ".xml") <- splitExtension f =

- Just $ presML ++ ".slide+xml"

- | "ppt" : "notesMasters" : f : [] <- splitDirectories fp

- , (_, ".xml") <- splitExtension f =

- Just $ presML ++ ".notesMaster+xml"

- | "ppt" : "notesSlides" : f : [] <- splitDirectories fp

- , (_, ".xml") <- splitExtension f =

- Just $ presML ++ ".notesSlide+xml"

- | "ppt" : "theme" : f : [] <- splitDirectories fp

- , (_, ".xml") <- splitExtension f =

- Just $ noPresML ++ ".theme+xml"

- | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp=

- Just $ presML ++ ".slideLayout+xml"

- | otherwise = Nothing

-

--------------------------------------------------------

-

-combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem]

-combineParaElems' mbPElem [] = maybeToList mbPElem

-combineParaElems' Nothing (pElem : pElems) =

- combineParaElems' (Just pElem) pElems

-combineParaElems' (Just pElem') (pElem : pElems)

- | Run rPr' s' <- pElem'

- , Run rPr s <- pElem

- , rPr == rPr' =

- combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems

- | otherwise =

- pElem' : combineParaElems' (Just pElem) pElems

-

-combineParaElems :: [ParaElem] -> [ParaElem]

-combineParaElems = combineParaElems' Nothing