{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Patat.Presentation.Read
( readPresentation
, 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
(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]
..}
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
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
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"
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
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)
}
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
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
_, []) -> []
(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