{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Patat.Presentation.Read
( readPresentation
, readMetaSettings
) where
import Control.Monad.Except (ExceptT (..), runExceptT,
throwError)
import Control.Monad.Trans (liftIO)
import qualified Data.Aeson as A
import Data.Bifunctor (first)
import qualified Data.HashMap.Strict as HMS
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Yaml as Yaml
import Patat.Eval (eval)
import Patat.Presentation.Fragment
import qualified Patat.Presentation.Instruction as Instruction
import Patat.Presentation.Internal
import Prelude
import System.Directory (doesFileExist,
getHomeDirectory)
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 filePath = runExceptT $ do
src <- liftIO $ T.readFile filePath
homeSettings <- ExceptT readHomeSettings
metaSettings <- ExceptT $ return $ readMetaSettings src
let settings = metaSettings <> homeSettings <> defaultPresentationSettings
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 filePath settings doc
liftIO $ eval pres
where
ext = takeExtension filePath
readExtension
:: ExtensionList -> String
-> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc)
readExtension (ExtensionList extensions) fileExt = case fileExt of
".md" -> 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
_ -> 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
:: FilePath -> PresentationSettings -> Pandoc.Pandoc
-> Either String Presentation
pandocToPresentation pFilePath pSettings 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)
return Presentation {..}
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
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 <- HMS.lookup "patat" obj ->
resultToEither $! A.fromJSON val
Just (Right _) -> Right mempty
where
resultToEither :: A.Result a -> Either String a
resultToEither (A.Success x) = Right x
resultToEither (A.Error e) = Left $!
"Error parsing patat settings from metadata: " ++ e
readHomeSettings :: IO (Either String PresentationSettings)
readHomeSettings = do
home <- getHomeDirectory
let path = home </> ".patat.yaml"
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 -> [Slide]
pandocToSlides settings pandoc =
let slideLevel = fromMaybe (detectSlideLevel pandoc) (psSlideLevel settings)
unfragmented = splitSlides slideLevel pandoc
fragmented =
[ case slide of
TitleSlide _ _ -> slide
ContentSlide instrs0 -> ContentSlide $
fragmentInstructions fragmentSettings instrs0
| slide <- unfragmented
] in
fragmented
where
fragmentSettings = FragmentSettings
{ fsIncrementalLists = fromMaybe False (psIncrementalLists settings)
}
detectSlideLevel :: Pandoc.Pandoc -> Int
detectSlideLevel (Pandoc.Pandoc _meta blocks0) =
go 6 blocks0
where
go level (Pandoc.Header n _ _ : x : xs)
| n < level && nonHeader x = go n xs
| otherwise = go level (x:xs)
go level (_ : xs) = go level xs
go level [] = level
nonHeader (Pandoc.Header _ _ _) = False
nonHeader _ = True
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 [] = []
mkContentSlide bs =
[ContentSlide $ Instruction.fromList [Instruction.Append bs]]
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) : bs)
| i > slideLevel = splitAtHeaders (b : acc) bs
| i == slideLevel =
mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs
| otherwise =
mkContentSlide (reverse acc) ++ [TitleSlide i txt] ++
splitAtHeaders [] bs
splitAtHeaders acc (b : bs) =
splitAtHeaders (b : acc) bs
collectBreadcrumbs :: [Slide] -> [Breadcrumbs]
collectBreadcrumbs = go []
where
go breadcrumbs = \case
[] -> []
ContentSlide _ : slides -> breadcrumbs : go breadcrumbs slides
TitleSlide lvl inlines : slides ->
let parent = filter ((< lvl) . fst) breadcrumbs in
parent : go (parent ++ [(lvl, inlines)]) slides