-- | Read a presentation from disk.
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Patat.Presentation.Read
    ( readPresentation

      -- Exposed for testing mostly.
    , detectSlideLevel
    , readMetaSettings
    ) where


--------------------------------------------------------------------------------
import           Control.Monad.Except           (ExceptT (..), runExceptT,
                                                 throwError)
import           Control.Monad.Trans            (liftIO)
import qualified Data.Aeson.Extended            as A
import qualified Data.Aeson.KeyMap              as AKM
import           Data.Bifunctor                 (first)
import           Data.Maybe                     (fromMaybe)
import           Data.Sequence.Extended         (Seq)
import qualified Data.Sequence.Extended         as Seq
import qualified Data.Text                      as T
import qualified Data.Text.Encoding             as T
import           Data.Traversable               (for)
import qualified Data.Yaml                      as Yaml
import           Patat.EncodingFallback         (EncodingFallback)
import qualified Patat.EncodingFallback         as EncodingFallback
import           Patat.Eval                     (eval)
import qualified Patat.Presentation.Comments    as Comments
import           Patat.Presentation.Fragment
import qualified Patat.Presentation.Instruction as Instruction
import           Patat.Presentation.Internal
import           Patat.Transition               (parseTransitionSettings)
import           Prelude
import qualified Skylighting                    as Skylighting
import           System.Directory               (XdgDirectory (XdgConfig),
                                                 doesFileExist,
                                                 getHomeDirectory,
                                                 getXdgDirectory)
import           System.FilePath                (splitFileName, takeExtension,
                                                 (</>))
import qualified Text.Pandoc.Error              as Pandoc
import qualified Text.Pandoc.Extended           as Pandoc


--------------------------------------------------------------------------------
readPresentation :: FilePath -> IO (Either String Presentation)
readPresentation :: [Char] -> IO (Either [Char] Presentation)
readPresentation [Char]
filePath = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    -- We need to read the settings first.
    (EncodingFallback
enc, Text
src)   <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO (EncodingFallback, Text)
EncodingFallback.readFile [Char]
filePath
    PresentationSettings
homeSettings <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT IO (Either [Char] PresentationSettings)
readHomeSettings
    PresentationSettings
xdgSettings  <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT IO (Either [Char] PresentationSettings)
readXdgSettings
    PresentationSettings
metaSettings <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Either [Char] PresentationSettings
readMetaSettings Text
src
    let settings :: PresentationSettings
settings =
            PresentationSettings
metaSettings forall a. Semigroup a => a -> a -> a
<>
            PresentationSettings
xdgSettings  forall a. Semigroup a => a -> a -> a
<>
            PresentationSettings
homeSettings forall a. Semigroup a => a -> a -> a
<>
            PresentationSettings
defaultPresentationSettings

    SyntaxMap
syntaxMap <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ [[Char]] -> IO (Either [Char] SyntaxMap)
readSyntaxMap forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$
        PresentationSettings -> Maybe [[Char]]
psSyntaxDefinitions PresentationSettings
settings
    let pexts :: ExtensionList
pexts = forall a. a -> Maybe a -> a
fromMaybe ExtensionList
defaultExtensionList (PresentationSettings -> Maybe ExtensionList
psPandocExtensions PresentationSettings
settings)
    Text -> Either PandocError Pandoc
reader <- case ExtensionList
-> [Char] -> Maybe (Text -> Either PandocError Pandoc)
readExtension ExtensionList
pexts [Char]
ext of
        Maybe (Text -> Either PandocError Pandoc)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown file extension: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
ext
        Just Text -> Either PandocError Pandoc
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return Text -> Either PandocError Pandoc
x
    Pandoc
doc <- case Text -> Either PandocError Pandoc
reader Text
src of
        Left  PandocError
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char]
"Could not parse document: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PandocError
e
        Right Pandoc
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
x

    Presentation
pres <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        [Char]
-> EncodingFallback
-> PresentationSettings
-> SyntaxMap
-> Pandoc
-> Either [Char] Presentation
pandocToPresentation [Char]
filePath EncodingFallback
enc PresentationSettings
settings SyntaxMap
syntaxMap Pandoc
doc
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Presentation -> IO Presentation
eval Presentation
pres
  where
    ext :: [Char]
ext = [Char] -> [Char]
takeExtension [Char]
filePath


--------------------------------------------------------------------------------
readSyntaxMap :: [FilePath] -> IO (Either String Skylighting.SyntaxMap)
readSyntaxMap :: [[Char]] -> IO (Either [Char] SyntaxMap)
readSyntaxMap =
    forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Syntax -> SyntaxMap -> SyntaxMap
Skylighting.addSyntaxDefinition forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO (Either [Char] Syntax)
Skylighting.loadSyntaxFromFile)


--------------------------------------------------------------------------------
readExtension
    :: ExtensionList -> String
    -> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc)
readExtension :: ExtensionList
-> [Char] -> Maybe (Text -> Either PandocError Pandoc)
readExtension (ExtensionList Extensions
extensions) [Char]
fileExt = case [Char]
fileExt of
    [Char]
".markdown" -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
    [Char]
".md"       -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
    [Char]
".mdown"    -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
    [Char]
".mdtext"   -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
    [Char]
".mdtxt"    -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
    [Char]
".mdwn"     -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
    [Char]
".mkd"      -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
    [Char]
".mkdn"     -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
    [Char]
".lhs"      -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
lhsOpts
    [Char]
""          -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
    [Char]
".org"      -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. PandocPure a -> Either PandocError a
Pandoc.runPure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readOrg      ReaderOptions
readerOpts
    [Char]
".txt"      -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Pandoc
Pandoc.readPlainText
    [Char]
_           -> forall a. Maybe a
Nothing

  where
    readerOpts :: ReaderOptions
readerOpts = forall a. Default a => a
Pandoc.def
        { readerExtensions :: Extensions
Pandoc.readerExtensions =
            Extensions
extensions forall a. Semigroup a => a -> a -> a
<> Extensions
absolutelyRequiredExtensions
        }

    lhsOpts :: ReaderOptions
lhsOpts = ReaderOptions
readerOpts
        { readerExtensions :: Extensions
Pandoc.readerExtensions =
            ReaderOptions -> Extensions
Pandoc.readerExtensions ReaderOptions
readerOpts forall a. Semigroup a => a -> a -> a
<>
            [Extension] -> Extensions
Pandoc.extensionsFromList [Extension
Pandoc.Ext_literate_haskell]
        }

    absolutelyRequiredExtensions :: Extensions
absolutelyRequiredExtensions =
        [Extension] -> Extensions
Pandoc.extensionsFromList [Extension
Pandoc.Ext_yaml_metadata_block]


--------------------------------------------------------------------------------
pandocToPresentation
    :: FilePath -> EncodingFallback -> PresentationSettings
    -> Skylighting.SyntaxMap -> Pandoc.Pandoc -> Either String Presentation
pandocToPresentation :: [Char]
-> EncodingFallback
-> PresentationSettings
-> SyntaxMap
-> Pandoc
-> Either [Char] Presentation
pandocToPresentation [Char]
pFilePath EncodingFallback
pEncodingFallback PresentationSettings
pSettings SyntaxMap
pSyntaxMap
        pandoc :: Pandoc
pandoc@(Pandoc.Pandoc Meta
meta [Block]
_) = do
    let !pTitle :: [Inline]
pTitle          = case Meta -> [Inline]
Pandoc.docTitle Meta
meta of
            []    -> [Text -> Inline
Pandoc.Str forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ [Char] -> ([Char], [Char])
splitFileName [Char]
pFilePath]
            [Inline]
title -> [Inline]
title
        !pSlides :: Seq Slide
pSlides         = PresentationSettings -> Pandoc -> Seq Slide
pandocToSlides PresentationSettings
pSettings Pandoc
pandoc
        !pBreadcrumbs :: Seq Breadcrumbs
pBreadcrumbs    = Seq Slide -> Seq Breadcrumbs
collectBreadcrumbs Seq Slide
pSlides
        !pActiveFragment :: (Int, Int)
pActiveFragment = (Int
0, Int
0)
        !pAuthor :: [Inline]
pAuthor         = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Meta -> [[Inline]]
Pandoc.docAuthors Meta
meta)
    Seq PresentationSettings
pSlideSettings <- forall (f :: * -> *) a b.
Applicative f =>
(Int -> a -> f b) -> Seq a -> f (Seq b)
Seq.traverseWithIndex
        (\Int
i ->
            forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\[Char]
err -> [Char]
"on slide " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int
i forall a. Num a => a -> a -> a
+ Int
1) forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char]
err) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            Comment -> Either [Char] PresentationSettings
Comments.parseSlideSettings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slide -> Comment
slideComment)
        Seq Slide
pSlides
    Seq (Maybe TransitionGen)
pTransitionGens <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Seq PresentationSettings
pSlideSettings forall a b. (a -> b) -> a -> b
$ \PresentationSettings
slideSettings ->
        case PresentationSettings -> Maybe TransitionSettings
psTransition (PresentationSettings
slideSettings forall a. Semigroup a => a -> a -> a
<> PresentationSettings
pSettings) of
            Maybe TransitionSettings
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just TransitionSettings
ts -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TransitionSettings -> Either [Char] TransitionGen
parseTransitionSettings TransitionSettings
ts
    forall (m :: * -> *) a. Monad m => a -> m a
return Presentation {[Char]
[Inline]
(Int, Int)
SyntaxMap
Seq Breadcrumbs
Seq (Maybe TransitionGen)
Seq PresentationSettings
Seq Slide
EncodingFallback
PresentationSettings
pSyntaxMap :: SyntaxMap
pActiveFragment :: (Int, Int)
pTransitionGens :: Seq (Maybe TransitionGen)
pSlideSettings :: Seq PresentationSettings
pBreadcrumbs :: Seq Breadcrumbs
pSlides :: Seq Slide
pSettings :: PresentationSettings
pAuthor :: [Inline]
pTitle :: [Inline]
pEncodingFallback :: EncodingFallback
pFilePath :: [Char]
pTransitionGens :: Seq (Maybe TransitionGen)
pSlideSettings :: Seq PresentationSettings
pAuthor :: [Inline]
pActiveFragment :: (Int, Int)
pBreadcrumbs :: Seq Breadcrumbs
pSlides :: Seq Slide
pTitle :: [Inline]
pSyntaxMap :: SyntaxMap
pSettings :: PresentationSettings
pEncodingFallback :: EncodingFallback
pFilePath :: [Char]
..}


--------------------------------------------------------------------------------
-- | This re-parses the pandoc metadata block using the YAML library.  This
-- avoids the problems caused by pandoc involving rendering Markdown.  This
-- should only be used for settings though, not things like title / authors
-- since those /can/ contain markdown.
parseMetadataBlock :: T.Text -> Maybe (Either String A.Value)
parseMetadataBlock :: Text -> Maybe (Either [Char] Value)
parseMetadataBlock Text
src = case Text -> [Text]
T.lines Text
src of
    (Text
"---" : [Text]
ls) -> case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"---", Text
"..."]) [Text]
ls of
        ([Text]
_,     [])      -> forall a. Maybe a
Nothing
        ([Text]
block, (Text
_ : [Text]
_)) -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> [Char]
Yaml.prettyPrintParseException forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$! [Text]
block
    [Text]
_            -> forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
-- | Read settings from the metadata block in the Pandoc document.
readMetaSettings :: T.Text -> Either String PresentationSettings
readMetaSettings :: Text -> Either [Char] PresentationSettings
readMetaSettings Text
src = case Text -> Maybe (Either [Char] Value)
parseMetadataBlock Text
src of
    Maybe (Either [Char] Value)
Nothing -> forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty
    Just (Left [Char]
err) -> forall a b. a -> Either a b
Left [Char]
err
    Just (Right (A.Object Object
obj)) | Just Value
val <- forall v. Key -> KeyMap v -> Maybe v
AKM.lookup Key
"patat" Object
obj ->
       forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\[Char]
err -> [Char]
"Error parsing patat settings from metadata: " forall a. [a] -> [a] -> [a]
++ [Char]
err) forall a b. (a -> b) -> a -> b
$!
       forall a. Result a -> Either [Char] a
A.resultToEither forall a b. (a -> b) -> a -> b
$! forall a. FromJSON a => Value -> Result a
A.fromJSON Value
val
    Just (Right Value
_) -> forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty


--------------------------------------------------------------------------------
-- | Read settings from "$HOME/.patat.yaml".
readHomeSettings :: IO (Either String PresentationSettings)
readHomeSettings :: IO (Either [Char] PresentationSettings)
readHomeSettings = do
    [Char]
home <- IO [Char]
getHomeDirectory
    [Char] -> IO (Either [Char] PresentationSettings)
readSettings forall a b. (a -> b) -> a -> b
$ [Char]
home [Char] -> [Char] -> [Char]
</> [Char]
".patat.yaml"


--------------------------------------------------------------------------------
-- | Read settings from "$XDG_CONFIG_DIRECTORY/patat/config.yaml".
readXdgSettings :: IO (Either String PresentationSettings)
readXdgSettings :: IO (Either [Char] PresentationSettings)
readXdgSettings =
    XdgDirectory -> [Char] -> IO [Char]
getXdgDirectory XdgDirectory
XdgConfig ([Char]
"patat" [Char] -> [Char] -> [Char]
</> [Char]
"config.yaml") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> IO (Either [Char] PresentationSettings)
readSettings


--------------------------------------------------------------------------------
-- | Read settings from the specified path, if it exists.
readSettings :: FilePath -> IO (Either String PresentationSettings)
readSettings :: [Char] -> IO (Either [Char] PresentationSettings)
readSettings [Char]
path = do
    Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
path
    if Bool -> Bool
not Bool
exists
        then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty)
        else do
            Either ParseException PresentationSettings
errOrPs <- forall a. FromJSON a => [Char] -> IO (Either ParseException a)
Yaml.decodeFileEither [Char]
path
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! case Either ParseException PresentationSettings
errOrPs of
                Left  ParseException
err -> forall a b. a -> Either a b
Left (forall a. Show a => a -> [Char]
show ParseException
err)
                Right PresentationSettings
ps  -> forall a b. b -> Either a b
Right PresentationSettings
ps


--------------------------------------------------------------------------------
pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> Seq.Seq Slide
pandocToSlides :: PresentationSettings -> Pandoc -> Seq Slide
pandocToSlides PresentationSettings
settings Pandoc
pandoc =
    let slideLevel :: Int
slideLevel   = forall a. a -> Maybe a -> a
fromMaybe (Pandoc -> Int
detectSlideLevel Pandoc
pandoc) (PresentationSettings -> Maybe Int
psSlideLevel PresentationSettings
settings)
        unfragmented :: [Slide]
unfragmented = Int -> Pandoc -> [Slide]
splitSlides Int
slideLevel Pandoc
pandoc
        fragmented :: [Slide]
fragmented   = forall a b. (a -> b) -> [a] -> [b]
map Slide -> Slide
fragmentSlide [Slide]
unfragmented in
    forall a. [a] -> Seq a
Seq.fromList [Slide]
fragmented
  where
    fragmentSlide :: Slide -> Slide
fragmentSlide Slide
slide = case Slide -> SlideContent
slideContent Slide
slide of
        TitleSlide   Int
_ [Inline]
_     -> Slide
slide
        ContentSlide Instructions Block
instrs0 ->
            let instrs1 :: Instructions Block
instrs1 = FragmentSettings -> Instructions Block -> Instructions Block
fragmentInstructions FragmentSettings
fragmentSettings Instructions Block
instrs0 in
            Slide
slide {slideContent :: SlideContent
slideContent = Instructions Block -> SlideContent
ContentSlide Instructions Block
instrs1}

    fragmentSettings :: FragmentSettings
fragmentSettings = FragmentSettings
        { fsIncrementalLists :: Bool
fsIncrementalLists = forall a. a -> Maybe a -> a
fromMaybe Bool
False (PresentationSettings -> Maybe Bool
psIncrementalLists PresentationSettings
settings)
        }


--------------------------------------------------------------------------------
-- | Find level of header that starts slides.  This is defined as the least
-- header that occurs before a non-header in the blocks.
detectSlideLevel :: Pandoc.Pandoc -> Int
detectSlideLevel :: Pandoc -> Int
detectSlideLevel (Pandoc.Pandoc Meta
_meta [Block]
blocks0) =
    Int -> [Block] -> Int
go Int
6 forall a b. (a -> b) -> a -> b
$ [Block] -> [Block]
Comments.remove [Block]
blocks0
  where
    go :: Int -> [Block] -> Int
go Int
level (Pandoc.Header Int
n Attr
_ [Inline]
_ : Block
x : [Block]
xs)
        | Int
n forall a. Ord a => a -> a -> Bool
< Int
level Bool -> Bool -> Bool
&& Bool -> Bool
not (Block -> Bool
isHeader Block
x) = Int -> [Block] -> Int
go Int
n [Block]
xs
        | Bool
otherwise                     = Int -> [Block] -> Int
go Int
level (Block
xforall a. a -> [a] -> [a]
:[Block]
xs)
    go Int
level (Block
_ : [Block]
xs)                   = Int -> [Block] -> Int
go Int
level [Block]
xs
    go Int
level []                         = Int
level

    isHeader :: Block -> Bool
isHeader (Pandoc.Header Int
_ Attr
_ [Inline]
_) = Bool
True
    isHeader Block
_                     = Bool
False


--------------------------------------------------------------------------------
-- | Split a pandoc document into slides.  If the document contains horizonal
-- rules, we use those as slide delimiters.  If there are no horizontal rules,
-- we split using headers, determined by the slide level (see
-- 'detectSlideLevel').
splitSlides :: Int -> Pandoc.Pandoc -> [Slide]
splitSlides :: Int -> Pandoc -> [Slide]
splitSlides Int
slideLevel (Pandoc.Pandoc Meta
_meta [Block]
blocks0)
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== Block
Pandoc.HorizontalRule) [Block]
blocks0 = [Block] -> [Slide]
splitAtRules   [Block]
blocks0
    | Bool
otherwise                              = [Block] -> [Block] -> [Slide]
splitAtHeaders [] [Block]
blocks0
  where
    mkContentSlide :: [Pandoc.Block] -> [Slide]
    mkContentSlide :: [Block] -> [Slide]
mkContentSlide [Block]
bs0 = case [Block] -> (Comment, [Block])
Comments.partition [Block]
bs0 of
        (Comment
_,  [])  -> [] -- Never create empty slides
        (Comment
sn, [Block]
bs1) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> SlideContent -> Slide
Slide Comment
sn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instructions Block -> SlideContent
ContentSlide forall a b. (a -> b) -> a -> b
$
            forall a. [Instruction a] -> Instructions a
Instruction.fromList [forall a. [a] -> Instruction a
Instruction.Append [Block]
bs1]

    splitAtRules :: [Block] -> [Slide]
splitAtRules [Block]
blocks = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Block
Pandoc.HorizontalRule) [Block]
blocks of
        ([Block]
xs, [])           -> [Block] -> [Slide]
mkContentSlide [Block]
xs
        ([Block]
xs, (Block
_rule : [Block]
ys)) -> [Block] -> [Slide]
mkContentSlide [Block]
xs forall a. [a] -> [a] -> [a]
++ [Block] -> [Slide]
splitAtRules [Block]
ys

    splitAtHeaders :: [Block] -> [Block] -> [Slide]
splitAtHeaders [Block]
acc [] =
        [Block] -> [Slide]
mkContentSlide (forall a. [a] -> [a]
reverse [Block]
acc)
    splitAtHeaders [Block]
acc (b :: Block
b@(Pandoc.Header Int
i Attr
_ [Inline]
txt) : [Block]
bs0)
        | Int
i forall a. Ord a => a -> a -> Bool
> Int
slideLevel  = [Block] -> [Block] -> [Slide]
splitAtHeaders (Block
b forall a. a -> [a] -> [a]
: [Block]
acc) [Block]
bs0
        | Int
i forall a. Eq a => a -> a -> Bool
== Int
slideLevel =
            [Block] -> [Slide]
mkContentSlide (forall a. [a] -> [a]
reverse [Block]
acc) forall a. [a] -> [a] -> [a]
++ [Block] -> [Block] -> [Slide]
splitAtHeaders [Block
b] [Block]
bs0
        | Bool
otherwise       =
            let (Comment
sn, [Block]
bs1) = [Block] -> (Comment, [Block])
Comments.split [Block]
bs0 in
            [Block] -> [Slide]
mkContentSlide (forall a. [a] -> [a]
reverse [Block]
acc) forall a. [a] -> [a] -> [a]
++
            [Comment -> SlideContent -> Slide
Slide Comment
sn forall a b. (a -> b) -> a -> b
$ Int -> [Inline] -> SlideContent
TitleSlide Int
i [Inline]
txt] forall a. [a] -> [a] -> [a]
++
            [Block] -> [Block] -> [Slide]
splitAtHeaders [] [Block]
bs1
    splitAtHeaders [Block]
acc (Block
b : [Block]
bs) =
        [Block] -> [Block] -> [Slide]
splitAtHeaders (Block
b forall a. a -> [a] -> [a]
: [Block]
acc) [Block]
bs


--------------------------------------------------------------------------------
collectBreadcrumbs :: Seq Slide -> Seq Breadcrumbs
collectBreadcrumbs :: Seq Slide -> Seq Breadcrumbs
collectBreadcrumbs = Breadcrumbs -> Seq SlideContent -> Seq Breadcrumbs
go [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Slide -> SlideContent
slideContent
  where
    go :: Breadcrumbs -> Seq SlideContent -> Seq Breadcrumbs
go Breadcrumbs
breadcrumbs Seq SlideContent
slides0 = case forall a. Seq a -> ViewL a
Seq.viewl Seq SlideContent
slides0 of
        ViewL SlideContent
Seq.EmptyL -> forall a. Seq a
Seq.empty
        ContentSlide Instructions Block
_ Seq.:< Seq SlideContent
slides ->
            Breadcrumbs
breadcrumbs forall a. a -> Seq a -> Seq a
`Seq.cons` Breadcrumbs -> Seq SlideContent -> Seq Breadcrumbs
go Breadcrumbs
breadcrumbs Seq SlideContent
slides
        TitleSlide Int
lvl [Inline]
inlines Seq.:< Seq SlideContent
slides ->
            let parent :: Breadcrumbs
parent = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
< Int
lvl) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Breadcrumbs
breadcrumbs in
            Breadcrumbs
parent forall a. a -> Seq a -> Seq a
`Seq.cons` Breadcrumbs -> Seq SlideContent -> Seq Breadcrumbs
go (Breadcrumbs
parent forall a. [a] -> [a] -> [a]
++ [(Int
lvl, [Inline]
inlines)]) Seq SlideContent
slides