patat-0.12.0.0: lib/Patat/Presentation/Settings.hs
--------------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Patat.Presentation.Settings
( PresentationSettings (..)
, defaultPresentationSettings
, Wrap (..)
, AutoOr (..)
, MarginSettings (..)
, ExtensionList (..)
, defaultExtensionList
, ImageSettings (..)
, EvalSettingsMap
, EvalSettingsContainer (..)
, EvalSettings (..)
, SpeakerNotesSettings (..)
, TransitionSettings (..)
) where
--------------------------------------------------------------------------------
import Control.Applicative ((<|>))
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 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)
} 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
, 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
}
--------------------------------------------------------------------------------
instance Monoid PresentationSettings where
mappend = (<>)
mempty = PresentationSettings
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 (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 (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 (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 (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 EvalSettingsContainer
= EvalContainerCode
| EvalContainerNone
| EvalContainerInline
deriving (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
, evalFragment :: !Bool
, evalContainer :: !EvalSettingsContainer
} 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
<*> deprecated "wrap" "container" EvalContainerCode o
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 (Show)
--------------------------------------------------------------------------------
data TransitionSettings = TransitionSettings
{ tsType :: !T.Text
, tsParams :: !A.Object
} deriving (Show)
--------------------------------------------------------------------------------
instance A.FromJSON TransitionSettings where
parseJSON = A.withObject "FromJSON TransitionSettings" $ \o ->
TransitionSettings <$> o A..: "type" <*> pure o
--------------------------------------------------------------------------------
$(A.deriveFromJSON A.dropPrefixOptions ''MarginSettings)
$(A.deriveFromJSON A.dropPrefixOptions ''SpeakerNotesSettings)
$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings)