-- | 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 qualified Patat.Eval as Eval
import qualified Patat.Presentation.Comments as Comments
import Patat.Presentation.Fragment
import qualified Patat.Presentation.Instruction as Instruction
import Patat.Presentation.Instruction (VarGen)
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 :: VarGen -> FilePath -> IO (Either String Presentation)
readPresentation varGen filePath = runExceptT $ do
-- We need to read the settings first.
(enc, src) <- liftIO $ EncodingFallback.readFile filePath
homeSettings <- ExceptT readHomeSettings
xdgSettings <- ExceptT readXdgSettings
metaSettings <- ExceptT $ return $ readMetaSettings src
let settings =
metaSettings <>
xdgSettings <>
homeSettings <>
defaultPresentationSettings
syntaxMap <- ExceptT $ readSyntaxMap $ fromMaybe [] $
psSyntaxDefinitions settings
let pexts = fromMaybe defaultExtensionList (psPandocExtensions settings)
reader <- case readExtension pexts ext of
Nothing -> throwError $ "Unknown file extension: " ++ show ext
Just x -> return x
doc <- case reader src of
Left e -> throwError $ "Could not parse document: " ++ show e
Right x -> return x
pres <- ExceptT $ pure $
pandocToPresentation varGen filePath enc settings syntaxMap doc
pure $ Eval.parseEvalBlocks pres
where
ext = takeExtension filePath
--------------------------------------------------------------------------------
readSyntaxMap :: [FilePath] -> IO (Either String Skylighting.SyntaxMap)
readSyntaxMap =
runExceptT .
fmap (foldr Skylighting.addSyntaxDefinition mempty) .
traverse (ExceptT . Skylighting.loadSyntaxFromFile)
--------------------------------------------------------------------------------
readExtension
:: ExtensionList -> String
-> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc)
readExtension (ExtensionList extensions) fileExt = case fileExt of
".markdown" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
".md" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
".mdown" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
".mdtext" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
".mdtxt" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
".mdwn" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
".mkd" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
".mkdn" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
".lhs" -> Just $ Pandoc.runPure . Pandoc.readMarkdown lhsOpts
"" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
".org" -> Just $ Pandoc.runPure . Pandoc.readOrg readerOpts
".txt" -> Just $ pure . Pandoc.readPlainText
_ -> Nothing
where
readerOpts = Pandoc.def
{ Pandoc.readerExtensions =
extensions <> absolutelyRequiredExtensions
}
lhsOpts = readerOpts
{ Pandoc.readerExtensions =
Pandoc.readerExtensions readerOpts <>
Pandoc.extensionsFromList [Pandoc.Ext_literate_haskell]
}
absolutelyRequiredExtensions =
Pandoc.extensionsFromList [Pandoc.Ext_yaml_metadata_block]
--------------------------------------------------------------------------------
pandocToPresentation
:: VarGen -> FilePath -> EncodingFallback -> PresentationSettings
-> Skylighting.SyntaxMap -> Pandoc.Pandoc -> Either String Presentation
pandocToPresentation pVarGen pFilePath pEncodingFallback pSettings pSyntaxMap
pandoc@(Pandoc.Pandoc meta _) = do
let !pTitle = case Pandoc.docTitle meta of
[] -> [Pandoc.Str . T.pack . snd $ splitFileName pFilePath]
title -> title
!pSlides = pandocToSlides pSettings pandoc
!pBreadcrumbs = collectBreadcrumbs pSlides
!pActiveFragment = (0, 0)
!pAuthor = concat (Pandoc.docAuthors meta)
!pEvalBlocks = mempty
!pVars = mempty
pSlideSettings <- Seq.traverseWithIndex
(\i ->
first (\err -> "on slide " ++ show (i + 1) ++ ": " ++ err) .
Comments.parseSlideSettings . slideComment)
pSlides
pTransitionGens <- for pSlideSettings $ \slideSettings ->
case psTransition (slideSettings <> pSettings) of
Nothing -> pure Nothing
Just ts -> Just <$> parseTransitionSettings ts
return Presentation {..}
--------------------------------------------------------------------------------
-- | 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 src = case T.lines src of
("---" : ls) -> case break (`elem` ["---", "..."]) ls of
(_, []) -> Nothing
(block, (_ : _)) -> Just . first Yaml.prettyPrintParseException .
Yaml.decodeEither' . T.encodeUtf8 . T.unlines $! block
_ -> Nothing
--------------------------------------------------------------------------------
-- | Read settings from the metadata block in the Pandoc document.
readMetaSettings :: T.Text -> Either String PresentationSettings
readMetaSettings src = case parseMetadataBlock src of
Nothing -> Right mempty
Just (Left err) -> Left err
Just (Right (A.Object obj)) | Just val <- AKM.lookup "patat" obj ->
first (\err -> "Error parsing patat settings from metadata: " ++ err) $!
A.resultToEither $! A.fromJSON val
Just (Right _) -> Right mempty
--------------------------------------------------------------------------------
-- | Read settings from "$HOME/.patat.yaml".
readHomeSettings :: IO (Either String PresentationSettings)
readHomeSettings = do
home <- getHomeDirectory
readSettings $ home </> ".patat.yaml"
--------------------------------------------------------------------------------
-- | Read settings from "$XDG_CONFIG_DIRECTORY/patat/config.yaml".
readXdgSettings :: IO (Either String PresentationSettings)
readXdgSettings =
getXdgDirectory XdgConfig ("patat" </> "config.yaml") >>= readSettings
--------------------------------------------------------------------------------
-- | Read settings from the specified path, if it exists.
readSettings :: FilePath -> IO (Either String PresentationSettings)
readSettings path = do
exists <- doesFileExist path
if not exists
then return (Right mempty)
else do
errOrPs <- Yaml.decodeFileEither path
return $! case errOrPs of
Left err -> Left (show err)
Right ps -> Right ps
--------------------------------------------------------------------------------
pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> Seq.Seq Slide
pandocToSlides settings pandoc =
let slideLevel = fromMaybe (detectSlideLevel pandoc) (psSlideLevel settings)
unfragmented = splitSlides slideLevel pandoc
fragmented = map fragmentSlide unfragmented in
Seq.fromList fragmented
where
fragmentSlide slide = case slideContent slide of
TitleSlide _ _ -> slide
ContentSlide instrs0 ->
let instrs1 = fragmentInstructions fragmentSettings instrs0 in
slide {slideContent = ContentSlide instrs1}
fragmentSettings = FragmentSettings
{ fsIncrementalLists = fromMaybe False (psIncrementalLists 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.Pandoc _meta blocks0) =
go 6 $ Comments.remove blocks0
where
go level (Pandoc.Header n _ _ : x : xs)
| n < level && not (isHeader x) = go n xs
| otherwise = go level (x:xs)
go level (_ : xs) = go level xs
go level [] = level
isHeader (Pandoc.Header _ _ _) = True
isHeader _ = 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 slideLevel (Pandoc.Pandoc _meta blocks0)
| any (== Pandoc.HorizontalRule) blocks0 = splitAtRules blocks0
| otherwise = splitAtHeaders [] blocks0
where
mkContentSlide :: [Pandoc.Block] -> [Slide]
mkContentSlide bs0 = case Comments.partition bs0 of
(_, []) -> [] -- Never create empty slides
(sn, bs1) -> pure . Slide sn . ContentSlide $
Instruction.fromList [Instruction.Append bs1]
splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of
(xs, []) -> mkContentSlide xs
(xs, (_rule : ys)) -> mkContentSlide xs ++ splitAtRules ys
splitAtHeaders acc [] =
mkContentSlide (reverse acc)
splitAtHeaders acc (b@(Pandoc.Header i _ txt) : bs0)
| i > slideLevel = splitAtHeaders (b : acc) bs0
| i == slideLevel =
mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs0
| otherwise =
let (sn, bs1) = Comments.split bs0 in
mkContentSlide (reverse acc) ++
[Slide sn $ TitleSlide i txt] ++
splitAtHeaders [] bs1
splitAtHeaders acc (b : bs) =
splitAtHeaders (b : acc) bs
--------------------------------------------------------------------------------
collectBreadcrumbs :: Seq Slide -> Seq Breadcrumbs
collectBreadcrumbs = go [] . fmap slideContent
where
go breadcrumbs slides0 = case Seq.viewl slides0 of
Seq.EmptyL -> Seq.empty
ContentSlide _ Seq.:< slides ->
breadcrumbs `Seq.cons` go breadcrumbs slides
TitleSlide lvl inlines Seq.:< slides ->
let parent = filter ((< lvl) . fst) breadcrumbs in
parent `Seq.cons` go (parent ++ [(lvl, inlines)]) slides