{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Readers.Pptx.Slides
   Copyright   : © 2025 Anton Antic
   License     : GNU GPL, version 2 or above

   Maintainer  : Anton Antic <anton@everworker.ai>
   Stability   : alpha
   Portability : portable

Conversion of PPTX slides to Pandoc AST blocks.
-}
module Text.Pandoc.Readers.Pptx.Slides
  ( pptxToOutput
  ) where

import Codec.Archive.Zip (Archive)
import Data.List (find)
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Data.Text (Text)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Options (ReaderOptions)
import Text.Pandoc.Readers.OOXML.Shared
import Text.Pandoc.Readers.Pptx.Parse
import Text.Pandoc.Readers.Pptx.Shapes
import Text.Pandoc.XML.Light

-- | Convert Pptx intermediate representation to Pandoc AST
pptxToOutput :: PandocMonad m => ReaderOptions -> Pptx -> m (Meta, [Block])
pptxToOutput :: forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Pptx -> m (Meta, [Block])
pptxToOutput ReaderOptions
_opts Pptx
pptx = do
  let slides :: [PptxSlide]
slides = Pptx -> [PptxSlide]
pptxSlides Pptx
pptx
      archive :: Archive
archive = Pptx -> Archive
pptxArchive Pptx
pptx

  -- Convert each slide to blocks
  [Block]
slideBlocks <- [[Block]] -> [Block]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Block]] -> [Block]) -> m [[Block]] -> m [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PptxSlide -> m [Block]) -> [PptxSlide] -> m [[Block]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Archive -> PptxSlide -> m [Block]
forall (m :: * -> *).
PandocMonad m =>
Archive -> PptxSlide -> m [Block]
slideToBlocks Archive
archive) [PptxSlide]
slides

  (Meta, [Block]) -> m (Meta, [Block])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Meta
forall a. Monoid a => a
mempty, [Block]
slideBlocks)

-- | Convert slide to blocks
slideToBlocks :: PandocMonad m => Archive -> PptxSlide -> m [Block]
slideToBlocks :: forall (m :: * -> *).
PandocMonad m =>
Archive -> PptxSlide -> m [Block]
slideToBlocks Archive
archive PptxSlide
slide = do
  let SlideId Int
n = PptxSlide -> SlideId
slideId PptxSlide
slide
      slideElem :: Element
slideElem = PptxSlide -> Element
slideElement PptxSlide
slide
      rels :: [(Text, Text)]
rels = PptxSlide -> [(Text, Text)]
slideRels PptxSlide
slide
      ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
slideElem

      -- Extract title from title placeholder
      title :: Text
title = NameSpaces -> Element -> Text
extractSlideTitle NameSpaces
ns Element
slideElem

      -- Create header
      slideIdent :: Text
slideIdent = Text
"slide-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)
      headerText :: Text
headerText = if Text -> Bool
T.null Text
title
                   then Text
"Slide " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)
                   else Text
title
      header :: Block
header = Int -> Attr -> [Inline] -> Block
Header Int
2 (Text
slideIdent, [], []) [Text -> Inline
Str Text
headerText]

  -- Parse shapes and convert to blocks
  case NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"p" Text
"cSld" Element
slideElem Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
       NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"p" Text
"spTree" of
    Maybe Element
Nothing -> [Block] -> m [Block]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Block
header]
    Just Element
spTree -> do
      -- Filter out title placeholder shapes before parsing
      let allShapeElems :: [Element]
allShapeElems = [Content] -> [Element]
onlyElems ([Content] -> [Element]) -> [Content] -> [Element]
forall a b. (a -> b) -> a -> b
$ Element -> [Content]
elContent Element
spTree
          nonTitleShapeElems :: [Element]
nonTitleShapeElems = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Element -> Bool) -> Element -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpaces -> Element -> Bool
isTitlePlaceholder NameSpaces
ns) [Element]
allShapeElems
          shapes :: [PptxShape]
shapes = (Element -> Maybe PptxShape) -> [Element] -> [PptxShape]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameSpaces -> Element -> Maybe PptxShape
parseShape NameSpaces
ns) [Element]
nonTitleShapeElems
      [Block]
shapeBlocks <- [[Block]] -> [Block]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Block]] -> [Block]) -> m [[Block]] -> m [Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PptxShape -> m [Block]) -> [PptxShape] -> m [[Block]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Archive -> [(Text, Text)] -> PptxShape -> m [Block]
forall (m :: * -> *).
PandocMonad m =>
Archive -> [(Text, Text)] -> PptxShape -> m [Block]
shapeToBlocks Archive
archive [(Text, Text)]
rels) [PptxShape]
shapes
      [Block] -> m [Block]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Block] -> m [Block]) -> [Block] -> m [Block]
forall a b. (a -> b) -> a -> b
$ Block
header Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
shapeBlocks

-- | Extract title from title placeholder
extractSlideTitle :: NameSpaces -> Element -> Text
extractSlideTitle :: NameSpaces -> Element -> Text
extractSlideTitle NameSpaces
ns Element
slideElem =
  case NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"p" Text
"cSld" Element
slideElem Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
       NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"p" Text
"spTree" of
    Maybe Element
Nothing -> Text
""
    Just Element
spTree ->
      -- Find shape with ph type="title"
      let shapes :: [Element]
shapes = [Content] -> [Element]
onlyElems ([Content] -> [Element]) -> [Content] -> [Element]
forall a b. (a -> b) -> a -> b
$ Element -> [Content]
elContent Element
spTree
          titleShape :: Maybe Element
titleShape = (Element -> Bool) -> [Element] -> Maybe Element
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (NameSpaces -> Element -> Bool
isTitlePlaceholder NameSpaces
ns) [Element]
shapes
       in Text -> (Element -> Text) -> Maybe Element -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Element -> Text
extractDrawingMLText Maybe Element
titleShape

-- isTitlePlaceholder is imported from Shapes module