{-# 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 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 qualified Data.Yaml as Yaml
import Patat.EncodingFallback (EncodingFallback)
import qualified Patat.EncodingFallback as EncodingFallback
import Patat.Eval (eval)
import Patat.Presentation.Fragment
import qualified Patat.Presentation.Instruction as Instruction
import Patat.Presentation.Internal
import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes
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 :: String -> IO (Either String Presentation)
readPresentation String
filePath = ExceptT String IO Presentation -> IO (Either String Presentation)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO Presentation -> IO (Either String Presentation))
-> ExceptT String IO Presentation
-> IO (Either String Presentation)
forall a b. (a -> b) -> a -> b
$ do
(EncodingFallback
enc, Text
src) <- IO (EncodingFallback, Text)
-> ExceptT String IO (EncodingFallback, Text)
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EncodingFallback, Text)
-> ExceptT String IO (EncodingFallback, Text))
-> IO (EncodingFallback, Text)
-> ExceptT String IO (EncodingFallback, Text)
forall a b. (a -> b) -> a -> b
$ String -> IO (EncodingFallback, Text)
EncodingFallback.readFile String
filePath
PresentationSettings
homeSettings <- IO (Either String PresentationSettings)
-> ExceptT String IO PresentationSettings
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT IO (Either String PresentationSettings)
readHomeSettings
PresentationSettings
xdgSettings <- IO (Either String PresentationSettings)
-> ExceptT String IO PresentationSettings
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT IO (Either String PresentationSettings)
readXdgSettings
PresentationSettings
metaSettings <- IO (Either String PresentationSettings)
-> ExceptT String IO PresentationSettings
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String PresentationSettings)
-> ExceptT String IO PresentationSettings)
-> IO (Either String PresentationSettings)
-> ExceptT String IO PresentationSettings
forall a b. (a -> b) -> a -> b
$ Either String PresentationSettings
-> IO (Either String PresentationSettings)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String PresentationSettings
-> IO (Either String PresentationSettings))
-> Either String PresentationSettings
-> IO (Either String PresentationSettings)
forall a b. (a -> b) -> a -> b
$ Text -> Either String PresentationSettings
readMetaSettings Text
src
let settings :: PresentationSettings
settings =
PresentationSettings
metaSettings PresentationSettings
-> PresentationSettings -> PresentationSettings
forall a. Semigroup a => a -> a -> a
<>
PresentationSettings
xdgSettings PresentationSettings
-> PresentationSettings -> PresentationSettings
forall a. Semigroup a => a -> a -> a
<>
PresentationSettings
homeSettings PresentationSettings
-> PresentationSettings -> PresentationSettings
forall a. Semigroup a => a -> a -> a
<>
PresentationSettings
defaultPresentationSettings
SyntaxMap
syntaxMap <- IO (Either String SyntaxMap) -> ExceptT String IO SyntaxMap
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String SyntaxMap) -> ExceptT String IO SyntaxMap)
-> IO (Either String SyntaxMap) -> ExceptT String IO SyntaxMap
forall a b. (a -> b) -> a -> b
$ [String] -> IO (Either String SyntaxMap)
readSyntaxMap ([String] -> IO (Either String SyntaxMap))
-> [String] -> IO (Either String SyntaxMap)
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [String] -> [String]) -> Maybe [String] -> [String]
forall a b. (a -> b) -> a -> b
$
PresentationSettings -> Maybe [String]
psSyntaxDefinitions PresentationSettings
settings
let pexts :: ExtensionList
pexts = ExtensionList -> Maybe ExtensionList -> ExtensionList
forall a. a -> Maybe a -> a
fromMaybe ExtensionList
defaultExtensionList (PresentationSettings -> Maybe ExtensionList
psPandocExtensions PresentationSettings
settings)
Text -> Either PandocError Pandoc
reader <- case ExtensionList
-> String -> Maybe (Text -> Either PandocError Pandoc)
readExtension ExtensionList
pexts String
ext of
Maybe (Text -> Either PandocError Pandoc)
Nothing -> String -> ExceptT String IO (Text -> Either PandocError Pandoc)
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String IO (Text -> Either PandocError Pandoc))
-> String -> ExceptT String IO (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ String
"Unknown file extension: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
ext
Just Text -> Either PandocError Pandoc
x -> (Text -> Either PandocError Pandoc)
-> ExceptT String IO (Text -> Either PandocError Pandoc)
forall a. a -> ExceptT String IO a
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 -> String -> ExceptT String IO Pandoc
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String IO Pandoc)
-> String -> ExceptT String IO Pandoc
forall a b. (a -> b) -> a -> b
$ String
"Could not parse document: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PandocError -> String
forall a. Show a => a -> String
show PandocError
e
Right Pandoc
x -> Pandoc -> ExceptT String IO Pandoc
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
x
Presentation
pres <- IO (Either String Presentation) -> ExceptT String IO Presentation
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String Presentation) -> ExceptT String IO Presentation)
-> IO (Either String Presentation)
-> ExceptT String IO Presentation
forall a b. (a -> b) -> a -> b
$ Either String Presentation -> IO (Either String Presentation)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Presentation -> IO (Either String Presentation))
-> Either String Presentation -> IO (Either String Presentation)
forall a b. (a -> b) -> a -> b
$
String
-> EncodingFallback
-> PresentationSettings
-> SyntaxMap
-> Pandoc
-> Either String Presentation
pandocToPresentation String
filePath EncodingFallback
enc PresentationSettings
settings SyntaxMap
syntaxMap Pandoc
doc
IO Presentation -> ExceptT String IO Presentation
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Presentation -> ExceptT String IO Presentation)
-> IO Presentation -> ExceptT String IO Presentation
forall a b. (a -> b) -> a -> b
$ Presentation -> IO Presentation
eval Presentation
pres
where
ext :: String
ext = String -> String
takeExtension String
filePath
readSyntaxMap :: [FilePath] -> IO (Either String Skylighting.SyntaxMap)
readSyntaxMap :: [String] -> IO (Either String SyntaxMap)
readSyntaxMap =
ExceptT String IO SyntaxMap -> IO (Either String SyntaxMap)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO SyntaxMap -> IO (Either String SyntaxMap))
-> ([String] -> ExceptT String IO SyntaxMap)
-> [String]
-> IO (Either String SyntaxMap)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
([Syntax] -> SyntaxMap)
-> ExceptT String IO [Syntax] -> ExceptT String IO SyntaxMap
forall a b. (a -> b) -> ExceptT String IO a -> ExceptT String IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Syntax -> SyntaxMap -> SyntaxMap)
-> SyntaxMap -> [Syntax] -> SyntaxMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Syntax -> SyntaxMap -> SyntaxMap
Skylighting.addSyntaxDefinition SyntaxMap
forall a. Monoid a => a
mempty) (ExceptT String IO [Syntax] -> ExceptT String IO SyntaxMap)
-> ([String] -> ExceptT String IO [Syntax])
-> [String]
-> ExceptT String IO SyntaxMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(String -> ExceptT String IO Syntax)
-> [String] -> ExceptT String IO [Syntax]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (IO (Either String Syntax) -> ExceptT String IO Syntax
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String Syntax) -> ExceptT String IO Syntax)
-> (String -> IO (Either String Syntax))
-> String
-> ExceptT String IO Syntax
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Either String Syntax)
Skylighting.loadSyntaxFromFile)
readExtension
:: ExtensionList -> String
-> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc)
readExtension :: ExtensionList
-> String -> Maybe (Text -> Either PandocError Pandoc)
readExtension (ExtensionList Extensions
extensions) String
fileExt = case String
fileExt of
String
".markdown" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
String
".md" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
String
".mdown" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
String
".mdtext" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
String
".mdtxt" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
String
".mdwn" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
String
".mkd" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
String
".mkdn" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
String
".lhs" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
lhsOpts
String
"" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
readerOpts
String
".org" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Text -> PandocPure Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readOrg ReaderOptions
readerOpts
String
".txt" -> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a. a -> Maybe a
Just ((Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc))
-> (Text -> Either PandocError Pandoc)
-> Maybe (Text -> Either PandocError Pandoc)
forall a b. (a -> b) -> a -> b
$ Pandoc -> Either PandocError Pandoc
forall a. a -> Either PandocError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pandoc -> Either PandocError Pandoc)
-> (Text -> Pandoc) -> Text -> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Pandoc
Pandoc.readPlainText
String
_ -> Maybe (Text -> Either PandocError Pandoc)
forall a. Maybe a
Nothing
where
readerOpts :: ReaderOptions
readerOpts = ReaderOptions
forall a. Default a => a
Pandoc.def
{ readerExtensions :: Extensions
Pandoc.readerExtensions =
Extensions
extensions Extensions -> 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 Extensions -> Extensions -> Extensions
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 :: String
-> EncodingFallback
-> PresentationSettings
-> SyntaxMap
-> Pandoc
-> Either String Presentation
pandocToPresentation String
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 (Text -> Inline)
-> ((String, String) -> Text) -> (String, String) -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> ((String, String) -> String) -> (String, String) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> Inline) -> (String, String) -> Inline
forall a b. (a -> b) -> a -> b
$ String -> (String, String)
splitFileName String
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 = [[Inline]] -> [Inline]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Meta -> [[Inline]]
Pandoc.docAuthors Meta
meta)
Presentation -> Either String Presentation
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return Presentation {String
[Inline]
(Int, Int)
SyntaxMap
Seq Breadcrumbs
Seq Slide
EncodingFallback
PresentationSettings
pFilePath :: String
pEncodingFallback :: EncodingFallback
pSettings :: PresentationSettings
pSyntaxMap :: SyntaxMap
pTitle :: [Inline]
pSlides :: Seq Slide
pBreadcrumbs :: Seq Breadcrumbs
pActiveFragment :: (Int, Int)
pAuthor :: [Inline]
pFilePath :: String
pEncodingFallback :: EncodingFallback
pTitle :: [Inline]
pAuthor :: [Inline]
pSettings :: PresentationSettings
pSlides :: Seq Slide
pBreadcrumbs :: Seq Breadcrumbs
pActiveFragment :: (Int, Int)
pSyntaxMap :: SyntaxMap
..}
parseMetadataBlock :: T.Text -> Maybe (Either String A.Value)
parseMetadataBlock :: Text -> Maybe (Either String Value)
parseMetadataBlock Text
src = case Text -> [Text]
T.lines Text
src of
(Text
"---" : [Text]
ls) -> case (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"---", Text
"..."]) [Text]
ls of
([Text]
_, []) -> Maybe (Either String Value)
forall a. Maybe a
Nothing
([Text]
block, (Text
_ : [Text]
_)) -> Either String Value -> Maybe (Either String Value)
forall a. a -> Maybe a
Just (Either String Value -> Maybe (Either String Value))
-> ([Text] -> Either String Value)
-> [Text]
-> Maybe (Either String Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseException -> String)
-> Either ParseException Value -> Either String Value
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseException -> String
Yaml.prettyPrintParseException (Either ParseException Value -> Either String Value)
-> ([Text] -> Either ParseException Value)
-> [Text]
-> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ByteString -> Either ParseException Value
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' (ByteString -> Either ParseException Value)
-> ([Text] -> ByteString) -> [Text] -> Either ParseException Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> ([Text] -> Text) -> [Text] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Maybe (Either String Value))
-> [Text] -> Maybe (Either String Value)
forall a b. (a -> b) -> a -> b
$! [Text]
block
[Text]
_ -> Maybe (Either String Value)
forall a. Maybe a
Nothing
readMetaSettings :: T.Text -> Either String PresentationSettings
readMetaSettings :: Text -> Either String PresentationSettings
readMetaSettings Text
src = case Text -> Maybe (Either String Value)
parseMetadataBlock Text
src of
Maybe (Either String Value)
Nothing -> PresentationSettings -> Either String PresentationSettings
forall a b. b -> Either a b
Right PresentationSettings
forall a. Monoid a => a
mempty
Just (Left String
err) -> String -> Either String PresentationSettings
forall a b. a -> Either a b
Left String
err
Just (Right (A.Object Object
obj)) | Just Value
val <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
AKM.lookup Key
"patat" Object
obj ->
Result PresentationSettings -> Either String PresentationSettings
forall a. Result a -> Either String a
resultToEither (Result PresentationSettings -> Either String PresentationSettings)
-> Result PresentationSettings
-> Either String PresentationSettings
forall a b. (a -> b) -> a -> b
$! Value -> Result PresentationSettings
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
val
Just (Right Value
_) -> PresentationSettings -> Either String PresentationSettings
forall a b. b -> Either a b
Right PresentationSettings
forall a. Monoid a => a
mempty
where
resultToEither :: A.Result a -> Either String a
resultToEither :: forall a. Result a -> Either String a
resultToEither (A.Success a
x) = a -> Either String a
forall a b. b -> Either a b
Right a
x
resultToEither (A.Error String
e) = String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$!
String
"Error parsing patat settings from metadata: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
readHomeSettings :: IO (Either String PresentationSettings)
readHomeSettings :: IO (Either String PresentationSettings)
readHomeSettings = do
String
home <- IO String
getHomeDirectory
String -> IO (Either String PresentationSettings)
readSettings (String -> IO (Either String PresentationSettings))
-> String -> IO (Either String PresentationSettings)
forall a b. (a -> b) -> a -> b
$ String
home String -> String -> String
</> String
".patat.yaml"
readXdgSettings :: IO (Either String PresentationSettings)
readXdgSettings :: IO (Either String PresentationSettings)
readXdgSettings =
XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig (String
"patat" String -> String -> String
</> String
"config.yaml") IO String
-> (String -> IO (Either String PresentationSettings))
-> IO (Either String PresentationSettings)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO (Either String PresentationSettings)
readSettings
readSettings :: FilePath -> IO (Either String PresentationSettings)
readSettings :: String -> IO (Either String PresentationSettings)
readSettings String
path = do
Bool
exists <- String -> IO Bool
doesFileExist String
path
if Bool -> Bool
not Bool
exists
then Either String PresentationSettings
-> IO (Either String PresentationSettings)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PresentationSettings -> Either String PresentationSettings
forall a b. b -> Either a b
Right PresentationSettings
forall a. Monoid a => a
mempty)
else do
Either ParseException PresentationSettings
errOrPs <- String -> IO (Either ParseException PresentationSettings)
forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither String
path
Either String PresentationSettings
-> IO (Either String PresentationSettings)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String PresentationSettings
-> IO (Either String PresentationSettings))
-> Either String PresentationSettings
-> IO (Either String PresentationSettings)
forall a b. (a -> b) -> a -> b
$! case Either ParseException PresentationSettings
errOrPs of
Left ParseException
err -> String -> Either String PresentationSettings
forall a b. a -> Either a b
Left (ParseException -> String
forall a. Show a => a -> String
show ParseException
err)
Right PresentationSettings
ps -> PresentationSettings -> Either String PresentationSettings
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 = Int -> Maybe Int -> Int
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 = (Slide -> Slide) -> [Slide] -> [Slide]
forall a b. (a -> b) -> [a] -> [b]
map Slide -> Slide
fragmentSlide [Slide]
unfragmented in
[Slide] -> Seq Slide
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 = Bool -> Maybe Bool -> Bool
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 ([Block] -> Int) -> [Block] -> Int
forall a b. (a -> b) -> a -> b
$ [Block] -> [Block]
SpeakerNotes.remove [Block]
blocks0
where
go :: Int -> [Block] -> Int
go Int
level (Pandoc.Header Int
n Attr
_ [Inline]
_ : Block
x : [Block]
xs)
| Int
n Int -> Int -> Bool
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
xBlock -> [Block] -> [Block]
forall 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)
| (Block -> Bool) -> [Block] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Block -> Block -> Bool
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] -> (SpeakerNotes, [Block])
SpeakerNotes.partition [Block]
bs0 of
(SpeakerNotes
_, []) -> []
(SpeakerNotes
sn, [Block]
bs1) -> Slide -> [Slide]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Slide -> [Slide])
-> (Instructions Block -> Slide) -> Instructions Block -> [Slide]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpeakerNotes -> SlideContent -> Slide
Slide SpeakerNotes
sn (SlideContent -> Slide)
-> (Instructions Block -> SlideContent)
-> Instructions Block
-> Slide
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instructions Block -> SlideContent
ContentSlide (Instructions Block -> [Slide]) -> Instructions Block -> [Slide]
forall a b. (a -> b) -> a -> b
$
[Instruction Block] -> Instructions Block
forall a. [Instruction a] -> Instructions a
Instruction.fromList [[Block] -> Instruction Block
forall a. [a] -> Instruction a
Instruction.Append [Block]
bs1]
splitAtRules :: [Block] -> [Slide]
splitAtRules [Block]
blocks = case (Block -> Bool) -> [Block] -> ([Block], [Block])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Block -> Block -> Bool
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 [Slide] -> [Slide] -> [Slide]
forall a. [a] -> [a] -> [a]
++ [Block] -> [Slide]
splitAtRules [Block]
ys
splitAtHeaders :: [Block] -> [Block] -> [Slide]
splitAtHeaders [Block]
acc [] =
[Block] -> [Slide]
mkContentSlide ([Block] -> [Block]
forall a. [a] -> [a]
reverse [Block]
acc)
splitAtHeaders [Block]
acc (b :: Block
b@(Pandoc.Header Int
i Attr
_ [Inline]
txt) : [Block]
bs0)
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
slideLevel = [Block] -> [Block] -> [Slide]
splitAtHeaders (Block
b Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
acc) [Block]
bs0
| Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
slideLevel =
[Block] -> [Slide]
mkContentSlide ([Block] -> [Block]
forall a. [a] -> [a]
reverse [Block]
acc) [Slide] -> [Slide] -> [Slide]
forall a. [a] -> [a] -> [a]
++ [Block] -> [Block] -> [Slide]
splitAtHeaders [Block
b] [Block]
bs0
| Bool
otherwise =
let (SpeakerNotes
sn, [Block]
bs1) = [Block] -> (SpeakerNotes, [Block])
SpeakerNotes.split [Block]
bs0 in
[Block] -> [Slide]
mkContentSlide ([Block] -> [Block]
forall a. [a] -> [a]
reverse [Block]
acc) [Slide] -> [Slide] -> [Slide]
forall a. [a] -> [a] -> [a]
++
[SpeakerNotes -> SlideContent -> Slide
Slide SpeakerNotes
sn (SlideContent -> Slide) -> SlideContent -> Slide
forall a b. (a -> b) -> a -> b
$ Int -> [Inline] -> SlideContent
TitleSlide Int
i [Inline]
txt] [Slide] -> [Slide] -> [Slide]
forall a. [a] -> [a] -> [a]
++
[Block] -> [Block] -> [Slide]
splitAtHeaders [] [Block]
bs1
splitAtHeaders [Block]
acc (Block
b : [Block]
bs) =
[Block] -> [Block] -> [Slide]
splitAtHeaders (Block
b Block -> [Block] -> [Block]
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 [] (Seq SlideContent -> Seq Breadcrumbs)
-> (Seq Slide -> Seq SlideContent) -> Seq Slide -> Seq Breadcrumbs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Slide -> SlideContent) -> Seq Slide -> Seq SlideContent
forall a b. (a -> b) -> Seq a -> Seq b
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 Seq SlideContent -> ViewL SlideContent
forall a. Seq a -> ViewL a
Seq.viewl Seq SlideContent
slides0 of
ViewL SlideContent
Seq.EmptyL -> Seq Breadcrumbs
forall a. Seq a
Seq.empty
ContentSlide Instructions Block
_ Seq.:< Seq SlideContent
slides ->
Breadcrumbs
breadcrumbs Breadcrumbs -> Seq Breadcrumbs -> Seq 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 = ((Int, [Inline]) -> Bool) -> Breadcrumbs -> Breadcrumbs
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lvl) (Int -> Bool)
-> ((Int, [Inline]) -> Int) -> (Int, [Inline]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [Inline]) -> Int
forall a b. (a, b) -> a
fst) Breadcrumbs
breadcrumbs in
Breadcrumbs
parent Breadcrumbs -> Seq Breadcrumbs -> Seq Breadcrumbs
forall a. a -> Seq a -> Seq a
`Seq.cons` Breadcrumbs -> Seq SlideContent -> Seq Breadcrumbs
go (Breadcrumbs
parent Breadcrumbs -> Breadcrumbs -> Breadcrumbs
forall a. [a] -> [a] -> [a]
++ [(Int
lvl, [Inline]
inlines)]) Seq SlideContent
slides