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

{-

Copyright (C) 2017 Jesse Rosenthal <jrosenthal@jhu.edu>

This program is free software; you can redistribute it and/or modify

it under the terms of the GNU General Public License as published by

the Free Software Foundation; either version 2 of the License, or

(at your option) any later version.

This program is distributed in the hope that it will be useful,

but WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

GNU General Public License for more details.

You should have received a copy of the GNU General Public License

along with this program; if not, write to the Free Software

Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

-}

{- |

   Module      : Text.Pandoc.Writers.Powerpoint

   Copyright   : Copyright (C) 2017 Jesse Rosenthal

   License     : GNU GPL, version 2 or above

   Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>

   Stability   : alpha

   Portability : portable

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

-}

module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where

import Control.Monad.Except (throwError)

import Control.Monad.Reader

import Control.Monad.State

import Codec.Archive.Zip

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

-- import Control.Monad (mplus)

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 Text.Pandoc.Definition

import qualified Text.Pandoc.UTF8 as UTF8

import Text.Pandoc.Class (PandocMonad)

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

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 qualified Data.ByteString.Lazy.Char8 as BL8

-- import qualified Text.Pandoc.UTF8 as UTF8

import Text.Pandoc.Walk

import Text.Pandoc.Writers.Shared (fixDisplayMath)

import Text.Pandoc.Writers.OOXML

import qualified Data.Map as M

import Data.Maybe (mapMaybe, listToMaybe)

import Text.Pandoc.ImageSize

import Control.Applicative ((<|>))

import Text.TeXMath

import Text.Pandoc.Writers.Math (convertMath)

writePowerpoint :: (PandocMonad m)

                => WriterOptions  -- ^ Writer options

                -> Pandoc         -- ^ Document to convert

                -> m BL.ByteString

writePowerpoint opts (Pandoc meta blks) = do

  let blks' = walk fixDisplayMath blks

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

                }

  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]

                          }

           deriving (Show, Eq)

data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape

  deriving (Show, Eq)

data Shape = Pic 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)

-- type StartingAt = Int

-- data AutoNumType = ArabicNum

--                  | AlphaUpperNum

--                  | AlphaLowerNum

--                  | RomanUpperNum

--                  | RomanLowerNum

--                  deriving (Show, Eq)

-- data AutoNumDelim = PeriodDelim

--                   | OneParenDelim

--                   | TwoParensDelim

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

                 }

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

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 = def{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 []

  -- parElems <- inlinesToParElems [Str str]

  -- paraProps <- asks envParaProps

  -- return [Paragraph paraProps parElems]

-- TODO: work out the format

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 _ blks)  = concatMapM blockToParagraphs blks

-- TODO

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 url attr <$> (inlinesToParElems ils)

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

      Pic 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

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

splitBlocks' cur acc ((Para (img@(Image _ _ _):ils)) : blks) = do

  slideLevel <- asks envSlideLevel

  case cur of

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

                            splitBlocks' []

                            (acc ++ [cur ++ [Para [img]]])

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

    _ ->  splitBlocks' []

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

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

splitBlocks' cur acc ((Plain (img@(Image _ _ _):ils)) : blks) = do

  slideLevel <- asks envSlideLevel

  case cur of

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

                            splitBlocks' []

                            (acc ++ [cur ++ [Para [img]]])

                            (if null ils then blks else (Plain ils) : blks)

    _ ->  splitBlocks' []

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

          (if null ils then blks else (Plain 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 (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

      inNoteSlide <- asks envInNoteSlide

      shapes <- if inNoteSlide

                then forceFontSize noteSize $ blocksToShapes blks

                else blocksToShapes blks

      return $ ContentSlide { contentSlideHeader = hdr

                            , contentSlideContent = shapes

                            }

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"

  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

  -- let ns = elemToNameSpaces root

  -- case findChild (elemName ns "p" "cSld") root of

  --   Just element' -> return element'

  --   Nothing       -> throwError $

  --                    PandocSomeError $

  --                    layoutpath ++ " not correctly formed layout file"

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

-- getContentTitleShape :: NameSpaces -> Element -> Maybe Element

-- getContentTitleShape ns spTreeElem

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

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

--   | otherwise = Nothing

-- getSubtitleShape :: NameSpaces -> Element -> Maybe Element

-- getSubtitleShape ns spTreeElem

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

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

--   | otherwise = Nothing

-- getDateShape :: NameSpaces -> Element -> Maybe Element

-- getDateShape ns spTreeElem

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

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

--   | otherwise = Nothing

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

-- cursorHasName :: QName -> XMLC.Cursor -> Bool

-- cursorHasName nm cur = case XMLC.current cur of

--   Elem element -> case XMLC.tagName $ XMLC.getTag element of

--                        nm -> True

--                        _ -> False

--   _ -> False

-- fillInTxBody :: NameSpaces -> [Paragraph] -> Element -> Element

-- fillInTxBody ns paras txBodyElem

--   | isElem ns "p" "txBody" txBodyElem =

--       replaceNamedChildren ns "a" "p" (map paragraphToElement paras) txBodyElem

--   | otherwise = txBodyElem

-- fillInShape :: NameSpaces -> Shape -> Element -> Element

-- fillInShape ns shape spElem

--   | TextBox paras <- shape

--   , isElemn ns "p" "sp" spElem =

--       replaceNamedChildren ns "p" "txBody" (fillInTxBody ns paras sp

-- fillInShape :: NameSpaces -> Element -> Shape -> Element

-- fillInShape ns spElem (TextBox paras) = fillInParagraphs ns spElem paras

-- fillInShape _ spElem pic = spElem

contentIsElem :: NameSpaces -> String -> String -> Content -> Bool

contentIsElem ns prefix name (Elem element) = isElem ns prefix name element

contentIsElem _ _ _ _ = False

replaceNamedChildren :: NameSpaces -> String -> String -> [Element] -> Element -> Element

replaceNamedChildren ns prefix name newKids element =

  let content = elContent element

      content' = filter (\c -> not (contentIsElem ns prefix name c)) content

  in

    element{elContent = content' ++ map Elem newKids}

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

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