patat-0.9.2.0: lib/Patat/Presentation/Internal.hs
--------------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Patat.Presentation.Internal
( Breadcrumbs
, Presentation (..)
, PresentationSettings (..)
, defaultPresentationSettings
, Margins (..)
, marginsOf
, ExtensionList (..)
, defaultExtensionList
, ImageSettings (..)
, EvalSettingsMap
, EvalSettings (..)
, Slide (..)
, SlideContent (..)
, Instruction.Fragment (..)
, Index
, getSlide
, numFragments
, ActiveFragment (..)
, activeFragment
, activeSpeakerNotes
) 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 Data.Function (on)
import qualified Data.HashMap.Strict as HMS
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.Sequence.Extended (Seq)
import qualified Data.Sequence.Extended as Seq
import qualified Data.Text as T
import Patat.EncodingFallback (EncodingFallback)
import qualified Patat.Presentation.Instruction as Instruction
import qualified Patat.Presentation.SpeakerNotes as SpeakerNotes
import qualified Patat.Theme as Theme
import Prelude
import qualified Skylighting as Skylighting
import qualified Text.Pandoc as Pandoc
import Text.Read (readMaybe)
--------------------------------------------------------------------------------
type Breadcrumbs = [(Int, [Pandoc.Inline])]
--------------------------------------------------------------------------------
data Presentation = Presentation
{ pFilePath :: !FilePath
, pEncodingFallback :: !EncodingFallback
, pTitle :: ![Pandoc.Inline]
, pAuthor :: ![Pandoc.Inline]
, pSettings :: !PresentationSettings
, pSlides :: !(Seq Slide)
, pBreadcrumbs :: !(Seq Breadcrumbs) -- One for each slide.
, pActiveFragment :: !Index
, pSyntaxMap :: !Skylighting.SyntaxMap
} 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)
, psSyntaxDefinitions :: !(Maybe [FilePath])
, psSpeakerNotes :: !(Maybe SpeakerNotes.Settings)
} deriving (Show)
--------------------------------------------------------------------------------
instance Semigroup PresentationSettings where
l <> r = PresentationSettings
{ psRows = on mplus psRows l r
, psColumns = on mplus psColumns l r
, psMargins = on (<>) psMargins l r
, psWrap = on mplus psWrap l r
, psTheme = on (<>) psTheme l r
, psIncrementalLists = on mplus psIncrementalLists l r
, psAutoAdvanceDelay = on mplus psAutoAdvanceDelay l r
, psSlideLevel = on mplus psSlideLevel l r
, psPandocExtensions = on mplus psPandocExtensions l r
, psImages = on mplus psImages l r
, psBreadcrumbs = on mplus psBreadcrumbs l r
, psEval = on (<>) psEval l r
, psSlideNumber = on mplus psSlideNumber l r
, psSyntaxDefinitions = on (<>) psSyntaxDefinitions l r
, psSpeakerNotes = on mplus psSpeakerNotes l r
}
--------------------------------------------------------------------------------
instance Monoid PresentationSettings where
mappend = (<>)
mempty = PresentationSettings
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
Nothing
--------------------------------------------------------------------------------
defaultPresentationSettings :: PresentationSettings
defaultPresentationSettings = mempty
{ psMargins = Just defaultMargins
, psTheme = Just Theme.defaultTheme
}
--------------------------------------------------------------------------------
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 ", " (map (drop 4 . show) allExts)
where
-- This is an approximation since we can't enumerate extensions
-- anymore in the latest pandoc...
allExts = Pandoc.extensionsToList $
Pandoc.getAllExtensions "markdown"
--------------------------------------------------------------------------------
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 = Slide
{ slideSpeakerNotes :: !SpeakerNotes.SpeakerNotes
, slideContent :: !SlideContent
} deriving (Show)
--------------------------------------------------------------------------------
data SlideContent
= 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 = (`Seq.safeIndex` sidx) . pSlides
--------------------------------------------------------------------------------
numFragments :: Slide -> Int
numFragments slide = case slideContent slide of
ContentSlide instrs -> Instruction.numFragments instrs
TitleSlide _ _ -> 1
--------------------------------------------------------------------------------
data ActiveFragment
= ActiveContent Instruction.Fragment
| ActiveTitle Pandoc.Block
deriving (Show)
--------------------------------------------------------------------------------
activeFragment :: Presentation -> Maybe ActiveFragment
activeFragment presentation = do
let (sidx, fidx) = pActiveFragment presentation
slide <- getSlide sidx presentation
pure $ case slideContent slide of
TitleSlide lvl is -> ActiveTitle $
Pandoc.Header lvl Pandoc.nullAttr is
ContentSlide instrs -> ActiveContent $
Instruction.renderFragment fidx instrs
--------------------------------------------------------------------------------
activeSpeakerNotes :: Presentation -> SpeakerNotes.SpeakerNotes
activeSpeakerNotes presentation = fromMaybe mempty $ do
let (sidx, _) = pActiveFragment presentation
slide <- getSlide sidx presentation
pure $ slideSpeakerNotes slide
--------------------------------------------------------------------------------
$(A.deriveFromJSON A.dropPrefixOptions ''Margins)
$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings)