-------------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Patat.Presentation.Internal ( Breadcrumbs , Presentation (..) , PresentationSettings (..) , defaultPresentationSettings , Margins (..) , marginsOf , ExtensionList (..) , defaultExtensionList , ImageSettings (..) , EvalSettingsMap , EvalSettings (..) , Slide (..) , Instruction.Fragment (..) , Index , getSlide , numFragments , ActiveFragment (..) , getActiveFragment ) where -------------------------------------------------------------------------------- import Control.Monad (mplus) import qualified Data.Aeson.Extended as A import qualified Data.Aeson.TH.Extended as A import qualified Data.Foldable as Foldable import qualified Data.HashMap.Strict as HMS import Data.List (intercalate) import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Text as T import qualified Patat.Presentation.Instruction as Instruction import qualified Patat.Theme as Theme import Prelude import qualified Text.Pandoc as Pandoc import Text.Read (readMaybe) -------------------------------------------------------------------------------- type Breadcrumbs = [(Int, [Pandoc.Inline])] -------------------------------------------------------------------------------- data Presentation = Presentation { pFilePath :: !FilePath , pTitle :: ![Pandoc.Inline] , pAuthor :: ![Pandoc.Inline] , pSettings :: !PresentationSettings , pSlides :: [Slide] , pBreadcrumbs :: [Breadcrumbs] -- One for each slide. , pActiveFragment :: !Index } deriving (Show) -------------------------------------------------------------------------------- -- | These are patat-specific settings. That is where they differ from more -- general metadata (author, title...) data PresentationSettings = PresentationSettings { psRows :: !(Maybe (A.FlexibleNum Int)) , psColumns :: !(Maybe (A.FlexibleNum Int)) , psMargins :: !(Maybe Margins) , psWrap :: !(Maybe Bool) , psTheme :: !(Maybe Theme.Theme) , psIncrementalLists :: !(Maybe Bool) , psAutoAdvanceDelay :: !(Maybe (A.FlexibleNum Int)) , psSlideLevel :: !(Maybe Int) , psPandocExtensions :: !(Maybe ExtensionList) , psImages :: !(Maybe ImageSettings) , psBreadcrumbs :: !(Maybe Bool) , psEval :: !(Maybe EvalSettingsMap) , psSlideNumber :: !(Maybe Bool) } deriving (Show) -------------------------------------------------------------------------------- instance Semigroup PresentationSettings where l <> r = PresentationSettings { psRows = psRows l `mplus` psRows r , psColumns = psColumns l `mplus` psColumns r , psMargins = psMargins l <> psMargins r , psWrap = psWrap l `mplus` psWrap r , psTheme = psTheme l <> psTheme r , psIncrementalLists = psIncrementalLists l `mplus` psIncrementalLists r , psAutoAdvanceDelay = psAutoAdvanceDelay l `mplus` psAutoAdvanceDelay r , psSlideLevel = psSlideLevel l `mplus` psSlideLevel r , psPandocExtensions = psPandocExtensions l `mplus` psPandocExtensions r , psImages = psImages l `mplus` psImages r , psBreadcrumbs = psBreadcrumbs l `mplus` psBreadcrumbs r , psEval = psEval l <> psEval r , psSlideNumber = psSlideNumber l `mplus` psSlideNumber r } -------------------------------------------------------------------------------- instance Monoid PresentationSettings where mappend = (<>) mempty = PresentationSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing -------------------------------------------------------------------------------- defaultPresentationSettings :: PresentationSettings defaultPresentationSettings = PresentationSettings { psRows = Nothing , psColumns = Nothing , psMargins = Just defaultMargins , psWrap = Nothing , psTheme = Just Theme.defaultTheme , psIncrementalLists = Nothing , psAutoAdvanceDelay = Nothing , psSlideLevel = Nothing , psPandocExtensions = Nothing , psImages = Nothing , psBreadcrumbs = Nothing , psEval = Nothing , psSlideNumber = Nothing } -------------------------------------------------------------------------------- data Margins = Margins { mLeft :: !(Maybe (A.FlexibleNum Int)) , mRight :: !(Maybe (A.FlexibleNum Int)) } deriving (Show) -------------------------------------------------------------------------------- instance Semigroup Margins where l <> r = Margins { mLeft = mLeft l `mplus` mLeft r , mRight = mRight l `mplus` mRight r } -------------------------------------------------------------------------------- instance Monoid Margins where mappend = (<>) mempty = Margins Nothing Nothing -------------------------------------------------------------------------------- defaultMargins :: Margins defaultMargins = Margins { mLeft = Nothing , mRight = Nothing } -------------------------------------------------------------------------------- marginsOf :: PresentationSettings -> (Int, Int) marginsOf presentationSettings = (marginLeft, marginRight) where margins = fromMaybe defaultMargins $ psMargins presentationSettings marginLeft = fromMaybe 0 (A.unFlexibleNum <$> mLeft margins) marginRight = fromMaybe 0 (A.unFlexibleNum <$> mRight margins) -------------------------------------------------------------------------------- newtype ExtensionList = ExtensionList {unExtensionList :: Pandoc.Extensions} deriving (Show) -------------------------------------------------------------------------------- instance A.FromJSON ExtensionList where parseJSON = A.withArray "FromJSON ExtensionList" $ fmap (ExtensionList . mconcat) . mapM parseExt . Foldable.toList where parseExt = A.withText "FromJSON ExtensionList" $ \txt -> case txt of -- Our default extensions "patat_extensions" -> return (unExtensionList defaultExtensionList) -- Individuals _ -> case readMaybe ("Ext_" ++ T.unpack txt) of Just e -> return $ Pandoc.extensionsFromList [e] Nothing -> fail $ "Unknown extension: " ++ show txt ++ ", known extensions are: " ++ intercalate ", " [ show (drop 4 (show e)) | e <- [minBound .. maxBound] :: [Pandoc.Extension] ] -------------------------------------------------------------------------------- defaultExtensionList :: ExtensionList defaultExtensionList = ExtensionList $ Pandoc.readerExtensions Pandoc.def `mappend` Pandoc.extensionsFromList [ Pandoc.Ext_yaml_metadata_block , Pandoc.Ext_table_captions , Pandoc.Ext_simple_tables , Pandoc.Ext_multiline_tables , Pandoc.Ext_grid_tables , Pandoc.Ext_pipe_tables , Pandoc.Ext_raw_html , Pandoc.Ext_tex_math_dollars , Pandoc.Ext_fenced_code_blocks , Pandoc.Ext_fenced_code_attributes , Pandoc.Ext_backtick_code_blocks , Pandoc.Ext_inline_code_attributes , Pandoc.Ext_fancy_lists , Pandoc.Ext_four_space_rule , Pandoc.Ext_definition_lists , Pandoc.Ext_compact_definition_lists , Pandoc.Ext_example_lists , Pandoc.Ext_strikeout , Pandoc.Ext_superscript , Pandoc.Ext_subscript ] -------------------------------------------------------------------------------- data ImageSettings = ImageSettings { isBackend :: !T.Text , isParams :: !A.Object } deriving (Show) -------------------------------------------------------------------------------- instance A.FromJSON ImageSettings where parseJSON = A.withObject "FromJSON ImageSettings" $ \o -> do t <- o A..: "backend" return ImageSettings {isBackend = t, isParams = o} -------------------------------------------------------------------------------- type EvalSettingsMap = HMS.HashMap T.Text EvalSettings -------------------------------------------------------------------------------- data EvalSettings = EvalSettings { evalCommand :: !T.Text , evalReplace :: !Bool , evalFragment :: !Bool } deriving (Show) -------------------------------------------------------------------------------- instance A.FromJSON EvalSettings where parseJSON = A.withObject "FromJSON EvalSettings" $ \o -> EvalSettings <$> o A..: "command" <*> o A..:? "replace" A..!= False <*> o A..:? "fragment" A..!= True -------------------------------------------------------------------------------- data Slide = ContentSlide (Instruction.Instructions Pandoc.Block) | TitleSlide Int [Pandoc.Inline] deriving (Show) -------------------------------------------------------------------------------- -- | Active slide, active fragment. type Index = (Int, Int) -------------------------------------------------------------------------------- getSlide :: Int -> Presentation -> Maybe Slide getSlide sidx = listToMaybe . drop sidx . pSlides -------------------------------------------------------------------------------- numFragments :: Slide -> Int numFragments (ContentSlide instrs) = Instruction.numFragments instrs numFragments (TitleSlide _ _) = 1 -------------------------------------------------------------------------------- data ActiveFragment = ActiveContent Instruction.Fragment | ActiveTitle Pandoc.Block deriving (Show) -------------------------------------------------------------------------------- getActiveFragment :: Presentation -> Maybe ActiveFragment getActiveFragment presentation = do let (sidx, fidx) = pActiveFragment presentation slide <- getSlide sidx presentation pure $ case slide of TitleSlide lvl is -> ActiveTitle $ Pandoc.Header lvl Pandoc.nullAttr is ContentSlide instrs -> ActiveContent $ Instruction.renderFragment fidx instrs -------------------------------------------------------------------------------- $(A.deriveFromJSON A.dropPrefixOptions ''Margins) $(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings)