-------------------------------------------------------------------------------- {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Patat.Presentation.Settings ( PresentationSettings (..) , defaultPresentationSettings , Wrap (..) , AutoOr (..) , MarginSettings (..) , ExtensionList (..) , defaultExtensionList , ImageSettings (..) , EvalSettingsMap (..) , EvalSettingsContainer (..) , EvalSettings (..) , SpeakerNotesSettings (..) , TransitionSettings (..) , LinkSettings (..) , parseSlideSettings ) where -------------------------------------------------------------------------------- import Control.Applicative ((<|>)) import Control.Monad (mplus, unless) import qualified Data.Aeson.Extended as A import qualified Data.Aeson.TH.Extended as A import Data.Bifunctor (first) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Data.Foldable as Foldable import Data.Function (on) import qualified Data.HashMap.Strict as HMS import Data.List (intercalate) import qualified Data.Text as T import qualified Patat.Theme as Theme import Prelude import qualified Text.Pandoc as Pandoc import Text.Read (readMaybe) -------------------------------------------------------------------------------- -- | 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 MarginSettings) , psWrap :: !(Maybe Wrap) , psTabStop :: !(Maybe (A.FlexibleNum Int)) , 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 SpeakerNotesSettings) , psTransition :: !(Maybe TransitionSettings) , psLinks :: !(Maybe LinkSettings) } deriving (Eq, 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 , psTabStop = on mplus psTabStop 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 , psTransition = on mplus psTransition l r , psLinks = on (<>) psLinks l r } -------------------------------------------------------------------------------- instance Monoid PresentationSettings where mappend = (<>) mempty = PresentationSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing -------------------------------------------------------------------------------- defaultPresentationSettings :: PresentationSettings defaultPresentationSettings = mempty { psMargins = Nothing , psTheme = Just Theme.defaultTheme } -------------------------------------------------------------------------------- data Wrap = NoWrap | AutoWrap | WrapAt Int deriving (Eq, Show) -------------------------------------------------------------------------------- instance A.FromJSON Wrap where parseJSON val = ((\w -> if w then AutoWrap else NoWrap) <$> A.parseJSON val) <|> (WrapAt <$> A.parseJSON val) -------------------------------------------------------------------------------- data AutoOr a = Auto | NotAuto a deriving (Eq, Show) -------------------------------------------------------------------------------- instance A.FromJSON a => A.FromJSON (AutoOr a) where parseJSON (A.String "auto") = pure Auto parseJSON val = NotAuto <$> A.parseJSON val -------------------------------------------------------------------------------- data MarginSettings = MarginSettings { msTop :: !(Maybe (AutoOr (A.FlexibleNum Int))) , msLeft :: !(Maybe (AutoOr (A.FlexibleNum Int))) , msRight :: !(Maybe (AutoOr (A.FlexibleNum Int))) } deriving (Eq, Show) -------------------------------------------------------------------------------- instance Semigroup MarginSettings where l <> r = MarginSettings { msTop = on mplus msTop l r , msLeft = on mplus msLeft l r , msRight = on mplus msRight l r } -------------------------------------------------------------------------------- instance Monoid MarginSettings where mappend = (<>) mempty = MarginSettings Nothing Nothing Nothing -------------------------------------------------------------------------------- newtype ExtensionList = ExtensionList {unExtensionList :: Pandoc.Extensions} deriving (Eq, 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 , Pandoc.Ext_shortcut_reference_links ] -------------------------------------------------------------------------------- data ImageSettings = ImageSettings { isBackend :: !T.Text , isParams :: !A.Object } deriving (Eq, Show) -------------------------------------------------------------------------------- instance A.FromJSON ImageSettings where parseJSON = A.withObject "FromJSON ImageSettings" $ \o -> do t <- o A..: "backend" return ImageSettings {isBackend = t, isParams = o} -------------------------------------------------------------------------------- newtype EvalSettingsMap = EvalSettingsMap (HMS.HashMap (CI T.Text) EvalSettings) deriving (Eq, Show, Semigroup) -------------------------------------------------------------------------------- instance A.FromJSON EvalSettingsMap where parseJSON = fmap (EvalSettingsMap . HMS.fromList . map (first CI.mk) . HMS.toList) . A.parseJSON -------------------------------------------------------------------------------- data EvalSettingsContainer = EvalContainerCode | EvalContainerNone | EvalContainerInline deriving (Eq, Show) -------------------------------------------------------------------------------- instance A.FromJSON EvalSettingsContainer where parseJSON = A.withText "FromJSON EvalSettingsContainer" $ \t -> case t of "code" -> pure EvalContainerCode "none" -> pure EvalContainerNone "inline" -> pure EvalContainerInline -- Deprecated names "raw" -> pure EvalContainerNone "rawInline" -> pure EvalContainerInline _ -> fail $ "unknown container: " <> show t -------------------------------------------------------------------------------- data EvalSettings = EvalSettings { evalCommand :: !T.Text , evalReplace :: !Bool , evalReveal :: !Bool , evalContainer :: !EvalSettingsContainer , evalStderr :: !Bool , evalSyntax :: !(Maybe (CI T.Text)) } deriving (Eq, Show) -------------------------------------------------------------------------------- instance A.FromJSON EvalSettings where parseJSON = A.withObject "FromJSON EvalSettings" $ \o -> EvalSettings <$> o A..: "command" <*> o A..:? "replace" A..!= False <*> deprecated "fragment" "reveal" True o <*> deprecated "wrap" "container" EvalContainerCode o <*> o A..:? "stderr" A..!= True <*> (fmap CI.mk <$> o A..:? "syntax") where deprecated old new def obj = do mo <- obj A..:? old mn <- obj A..:? new case (mo, mn) of (Just _, Just _) -> fail $ show old ++ " (deprecated) and " ++ show new ++ " " ++ "are both specified, please remove " ++ show old (Just o, Nothing) -> pure o (Nothing, Just n) -> pure n (Nothing, Nothing) -> pure def -------------------------------------------------------------------------------- data SpeakerNotesSettings = SpeakerNotesSettings { snsFile :: !FilePath } deriving (Eq, Show) -------------------------------------------------------------------------------- data TransitionSettings = TransitionSettings { tsType :: !T.Text , tsParams :: !A.Object } deriving (Eq, Show) -------------------------------------------------------------------------------- instance A.FromJSON TransitionSettings where parseJSON = A.withObject "FromJSON TransitionSettings" $ \o -> TransitionSettings <$> o A..: "type" <*> pure o -------------------------------------------------------------------------------- data LinkSettings = LinkSettings { lsOSC8 :: !(Maybe Bool) } deriving (Eq, Show) -------------------------------------------------------------------------------- instance Semigroup LinkSettings where l <> r = LinkSettings { lsOSC8 = on mplus lsOSC8 l r } -------------------------------------------------------------------------------- instance A.FromJSON LinkSettings where parseJSON = A.withObject "FromJSON LinkSettings" $ \o -> LinkSettings <$> o A..:? "osc8" -------------------------------------------------------------------------------- $(A.deriveFromJSON A.dropPrefixOptions ''MarginSettings) $(A.deriveFromJSON A.dropPrefixOptions ''SpeakerNotesSettings) $(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings) -------------------------------------------------------------------------------- data Setting where Setting :: String -> (PresentationSettings -> Maybe a) -> Setting -------------------------------------------------------------------------------- unsupportedSlideSettings :: [Setting] unsupportedSlideSettings = [ Setting "incrementalLists" psIncrementalLists , Setting "autoAdvanceDelay" psAutoAdvanceDelay , Setting "slideLevel" psSlideLevel , Setting "pandocExtensions" psPandocExtensions , Setting "images" psImages , Setting "eval" psEval , Setting "speakerNotes" psSpeakerNotes ] -------------------------------------------------------------------------------- parseSlideSettings :: PresentationSettings -> Either String PresentationSettings parseSlideSettings settings = do unless (null unsupported) $ Left $ "the following settings are not supported in slide config blocks: " ++ intercalate ", " unsupported pure settings where unsupported = do setting <- unsupportedSlideSettings case setting of Setting name f | Just _ <- f settings -> [name] Setting _ _ -> []