From f0ad6b10d5779fe57ca7aa66d0257e270cfabae8 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 28 Dec 2024 16:53:20 +0100 Subject: [PATCH] Refactor comments into proper AST nodes --- lib/Data/Aeson/Extended.hs | 2 +- lib/Patat/Presentation/Comments.hs | 96 ++----------------- lib/Patat/Presentation/Display.hs | 15 +-- lib/Patat/Presentation/Fragment.hs | 2 + lib/Patat/Presentation/Internal.hs | 7 +- lib/Patat/Presentation/Read.hs | 35 ++++--- lib/Patat/Presentation/Settings.hs | 20 ++-- lib/Patat/Presentation/Syntax.hs | 45 +++++++-- lib/Patat/Theme.hs | 6 +- .../haskell/Patat/Presentation/Read/Tests.hs | 2 +- 10 files changed, 100 insertions(+), 130 deletions(-) diff --git a/lib/Data/Aeson/Extended.hs b/lib/Data/Aeson/Extended.hs index 8db4ad6..ffb8791 100644 --- a/lib/Data/Aeson/Extended.hs +++ b/lib/Data/Aeson/Extended.hs @@ -14,7 +14,7 @@ import Text.Read (readMaybe) -- | This can be parsed from a JSON string in addition to a JSON number. newtype FlexibleNum a = FlexibleNum {unFlexibleNum :: a} - deriving (Show, ToJSON) + deriving (Eq, Show, ToJSON) instance (FromJSON a, Read a) => FromJSON (FlexibleNum a) where parseJSON (String str) = case readMaybe (T.unpack str) of diff --git a/lib/Patat/Presentation/Comments.hs b/lib/Patat/Presentation/Comments.hs index 218f8cb..90b762a 100644 --- a/lib/Patat/Presentation/Comments.hs +++ b/lib/Patat/Presentation/Comments.hs @@ -4,13 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Patat.Presentation.Comments - ( Comment (..) - , parse - , remove - , split - , partition - - , SpeakerNotes + ( SpeakerNotes (..) , speakerNotesToText , SpeakerNotesHandle @@ -22,91 +16,19 @@ module Patat.Presentation.Comments -------------------------------------------------------------------------------- -import Control.Applicative ((<|>)) import Control.Exception (bracket) import Control.Monad (unless, when) -import Data.Function (on) import qualified Data.IORef as IORef import Data.List (intercalate, intersperse) 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.EncodingFallback (EncodingFallback) import qualified Patat.EncodingFallback as EncodingFallback import Patat.Presentation.Settings -import Patat.Presentation.Syntax import System.Directory (removeFile) import qualified System.IO as IO --------------------------------------------------------------------------------- -data Comment = Comment - { cSpeakerNotes :: SpeakerNotes - , cConfig :: Either String PresentationSettings - } deriving (Show) - - --------------------------------------------------------------------------------- -instance Semigroup Comment where - l <> r = Comment - { cSpeakerNotes = on (<>) cSpeakerNotes l r - , cConfig = case (cConfig l, cConfig r) of - (Left err, _ ) -> Left err - (Right _, Left err) -> Left err - (Right x, Right y ) -> Right (x <> y) - } - - --------------------------------------------------------------------------------- -instance Monoid Comment where - mappend = (<>) - mempty = Comment mempty (Right mempty) - - --------------------------------------------------------------------------------- --- TODO: move to 'fromPandoc' -parse :: Block -> Maybe Comment -parse (RawBlock "html" t0) = - (do - t1 <- T.stripPrefix "" t1 - pure . Comment mempty $ case Yaml.decodeEither' (T.encodeUtf8 t2) of - Left err -> Left (show err) - Right obj -> Right obj) <|> - (do - t1 <- T.stripPrefix "" t1 - pure $ Comment (SpeakerNotes [T.strip t2]) (Right mempty)) -parse _ = Nothing - - --------------------------------------------------------------------------------- -remove :: [Block] -> [Block] -remove = snd . partition - - --------------------------------------------------------------------------------- --- | Take all comments from the front of the list. Return those and the --- remaining blocks. -split :: [Block] -> (Comment, [Block]) -split = go [] - where - go sn [] = (mconcat (reverse sn), []) - go sn (x : xs) | Just s <- parse x = go (s : sn) xs - go sn xs = (mconcat (reverse sn), xs) - - --------------------------------------------------------------------------------- --- | Partition the list into speaker notes and other blocks. -partition :: [Block] -> (Comment, [Block]) -partition = go [] [] - where - go sn bs [] = (mconcat (reverse sn), reverse bs) - go sn bs (x : xs) | Just s <- parse x = go (s : sn) bs xs - go sn bs (x : xs) = go sn (x : bs) xs - - -------------------------------------------------------------------------------- newtype SpeakerNotes = SpeakerNotes [T.Text] deriving (Eq, Monoid, Semigroup, Show) @@ -161,15 +83,15 @@ unsupportedSlideSettings = -------------------------------------------------------------------------------- -parseSlideSettings :: Comment -> Either String PresentationSettings -parseSlideSettings c = do - settings <- cConfig c - let unsupported = do - setting <- unsupportedSlideSettings - case setting of - Setting name f | Just _ <- f settings -> [name] - Setting _ _ -> [] +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 _ _ -> [] diff --git a/lib/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs index 78501a0..b56d189 100644 --- a/lib/Patat/Presentation/Display.hs +++ b/lib/Patat/Presentation/Display.hs @@ -147,18 +147,16 @@ dumpPresentation pres@Presentation {..} = dumpSlide :: Int -> [PP.Doc] dumpSlide i = do slide <- maybeToList $ getSlide i pres - dumpComment slide <> L.intercalate ["{fragment}"] + dumpSpeakerNotes slide <> L.intercalate ["{fragment}"] [ dumpFragment (i, j) | j <- [0 .. numFragments slide - 1] ] - dumpComment :: Slide -> [PP.Doc] - dumpComment slide = do - guard (Comments.cSpeakerNotes comment /= mempty) + dumpSpeakerNotes :: Slide -> [PP.Doc] + dumpSpeakerNotes slide = do + guard (slideSpeakerNotes slide /= mempty) pure $ PP.text $ "{speakerNotes: " <> - Comments.speakerNotesToText (Comments.cSpeakerNotes comment) <> "}" - where - comment = slideComment slide + Comments.speakerNotesToText (slideSpeakerNotes slide) <> "}" dumpFragment :: Index -> [PP.Doc] dumpFragment idx = @@ -324,6 +322,9 @@ prettyBlock ds (Figure _attr blocks) = -- TODO: the fromPandoc conversion here is weird prettyBlocks ds blocks +prettyBlock _ (SpeakerNote _) = mempty +prettyBlock _ (Config _) = mempty + -------------------------------------------------------------------------------- prettyBlocks :: DisplaySettings -> [Block] -> PP.Doc diff --git a/lib/Patat/Presentation/Fragment.hs b/lib/Patat/Presentation/Fragment.hs index c6f1def..a01f94a 100644 --- a/lib/Patat/Presentation/Fragment.hs +++ b/lib/Patat/Presentation/Fragment.hs @@ -70,6 +70,8 @@ fragmentBlock _ block@(Div {}) = [Append [block]] fragmentBlock _ block@HorizontalRule = [Append [block]] fragmentBlock _ block@(LineBlock {}) = [Append [block]] fragmentBlock _ block@(Figure {}) = [Append [block]] +fragmentBlock _ block@(SpeakerNote {}) = [Append [block]] +fragmentBlock _ block@(Config {}) = [Append [block]] fragmentList :: FragmentSettings -- ^ Global settings diff --git a/lib/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs index 45f8fc6..780bc58 100644 --- a/lib/Patat/Presentation/Internal.hs +++ b/lib/Patat/Presentation/Internal.hs @@ -109,8 +109,9 @@ margins ps = Margins -------------------------------------------------------------------------------- data Slide = Slide - { slideComment :: !Comments.Comment - , slideContent :: !SlideContent + { slideSpeakerNotes :: !Comments.SpeakerNotes + , slideSettings :: !(Either String PresentationSettings) + , slideContent :: !SlideContent } deriving (Show) @@ -165,7 +166,7 @@ activeSpeakerNotes :: Presentation -> Comments.SpeakerNotes activeSpeakerNotes presentation = fromMaybe mempty $ do let (sidx, _) = pActiveFragment presentation slide <- getSlide sidx presentation - pure . Comments.cSpeakerNotes $ slideComment slide + pure $ slideSpeakerNotes slide -------------------------------------------------------------------------------- diff --git a/lib/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs index 1b07971..f1e689b 100644 --- a/lib/Patat/Presentation/Read.hs +++ b/lib/Patat/Presentation/Read.hs @@ -16,6 +16,7 @@ module Patat.Presentation.Read import Control.Monad.Except (ExceptT (..), runExceptT, throwError) import Control.Monad.Trans (liftIO) +import Control.Monad (guard) import qualified Data.Aeson.Extended as A import qualified Data.Aeson.KeyMap as AKM import Data.Bifunctor (first) @@ -138,9 +139,9 @@ pandocToPresentation pVarGen pFilePath pEncodingFallback pSettings pSyntaxMap !pEvalBlocks = mempty !pVars = mempty pSlideSettings <- Seq.traverseWithIndex - (\i -> - first (\err -> "on slide " ++ show (i + 1) ++ ": " ++ err) . - Comments.parseSlideSettings . slideComment) + (\i slide -> case slideSettings slide of + Left err -> Left $ "on slide " ++ show (i + 1) ++ ": " ++ err + Right cfg -> pure cfg) pSlides pTransitionGens <- for pSlideSettings $ \slideSettings -> case psTransition (slideSettings <> pSettings) of @@ -229,7 +230,7 @@ pandocToSlides settings (Pandoc.Pandoc _meta pblocks) = -- header that occurs before a non-header in the blocks. detectSlideLevel :: [Block] -> Int detectSlideLevel blocks0 = - go 6 $ Comments.remove blocks0 + go 6 $ filter (not . isComment) blocks0 where go level (Header n _ _ : x : xs) | n < level && not (isHeader x) = go n xs @@ -248,16 +249,19 @@ detectSlideLevel blocks0 = -- 'detectSlideLevel'). splitSlides :: Int -> [Block] -> [Slide] splitSlides slideLevel blocks0 - | any (== HorizontalRule) blocks0 = splitAtRules blocks0 - | otherwise = splitAtHeaders [] blocks0 + | any isHorizontalRule blocks0 = splitAtRules blocks0 + | otherwise = splitAtHeaders [] blocks0 where mkContentSlide :: [Block] -> [Slide] - mkContentSlide bs0 = case Comments.partition bs0 of - (_, []) -> [] -- Never create empty slides - (sn, bs1) -> pure . Slide sn . ContentSlide $ + mkContentSlide bs0 = do + let bs1 = filter (not . isComment) bs0 + sns = Comments.SpeakerNotes [s | SpeakerNote s <- bs0] + cfgs = concatCfgs [cfg | Config cfg <- bs0] + guard $ not $ null bs1 -- Never create empty slides + pure $ Slide sns cfgs $ ContentSlide $ Instruction.fromList [Instruction.Append bs1] - splitAtRules blocks = case break (== HorizontalRule) blocks of + splitAtRules blocks = case break isHorizontalRule blocks of (xs, []) -> mkContentSlide xs (xs, (_rule : ys)) -> mkContentSlide xs ++ splitAtRules ys @@ -268,13 +272,20 @@ splitSlides slideLevel blocks0 | i == slideLevel = mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs0 | otherwise = - let (sn, bs1) = Comments.split bs0 in + let (cmnts, bs1) = break (not . isComment) bs0 + sns = Comments.SpeakerNotes [s | SpeakerNote s <- cmnts] + cfgs = concatCfgs [cfg | Config cfg <- cmnts] in mkContentSlide (reverse acc) ++ - [Slide sn $ TitleSlide i txt] ++ + [Slide sns cfgs $ TitleSlide i txt] ++ splitAtHeaders [] bs1 splitAtHeaders acc (b : bs) = splitAtHeaders (b : acc) bs + concatCfgs + :: [Either String PresentationSettings] + -> Either String PresentationSettings + concatCfgs = fmap mconcat . sequence + -------------------------------------------------------------------------------- collectBreadcrumbs :: Seq Slide -> Seq Breadcrumbs diff --git a/lib/Patat/Presentation/Settings.hs b/lib/Patat/Presentation/Settings.hs index 7ea13b7..d476540 100644 --- a/lib/Patat/Presentation/Settings.hs +++ b/lib/Patat/Presentation/Settings.hs @@ -62,7 +62,7 @@ data PresentationSettings = PresentationSettings , psSyntaxDefinitions :: !(Maybe [FilePath]) , psSpeakerNotes :: !(Maybe SpeakerNotesSettings) , psTransition :: !(Maybe TransitionSettings) - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -106,7 +106,7 @@ defaultPresentationSettings = mempty -------------------------------------------------------------------------------- -data Wrap = NoWrap | AutoWrap | WrapAt Int deriving (Show) +data Wrap = NoWrap | AutoWrap | WrapAt Int deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -117,7 +117,7 @@ instance A.FromJSON Wrap where -------------------------------------------------------------------------------- -data AutoOr a = Auto | NotAuto a deriving (Show) +data AutoOr a = Auto | NotAuto a deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -131,7 +131,7 @@ data MarginSettings = MarginSettings { msTop :: !(Maybe (AutoOr (A.FlexibleNum Int))) , msLeft :: !(Maybe (AutoOr (A.FlexibleNum Int))) , msRight :: !(Maybe (AutoOr (A.FlexibleNum Int))) - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -151,7 +151,7 @@ instance Monoid MarginSettings where -------------------------------------------------------------------------------- newtype ExtensionList = ExtensionList {unExtensionList :: Pandoc.Extensions} - deriving (Show) + deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -208,7 +208,7 @@ defaultExtensionList = ExtensionList $ data ImageSettings = ImageSettings { isBackend :: !T.Text , isParams :: !A.Object - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -227,7 +227,7 @@ data EvalSettingsContainer = EvalContainerCode | EvalContainerNone | EvalContainerInline - deriving (Show) + deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -249,7 +249,7 @@ data EvalSettings = EvalSettings , evalFragment :: !Bool , evalContainer :: !EvalSettingsContainer , evalStderr :: !Bool - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -276,14 +276,14 @@ instance A.FromJSON EvalSettings where -------------------------------------------------------------------------------- data SpeakerNotesSettings = SpeakerNotesSettings { snsFile :: !FilePath - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- data TransitionSettings = TransitionSettings { tsType :: !T.Text , tsParams :: !A.Object - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- diff --git a/lib/Patat/Presentation/Syntax.hs b/lib/Patat/Presentation/Syntax.hs index d9912f0..5180b24 100644 --- a/lib/Patat/Presentation/Syntax.hs +++ b/lib/Patat/Presentation/Syntax.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Patat.Presentation.Syntax ( Block (..) @@ -6,12 +7,18 @@ module Patat.Presentation.Syntax , dftInline , fromPandoc + + , isHorizontalRule + , isComment ) where -import qualified Data.Text as T -import Data.Traversable (for) -import qualified Text.Pandoc as Pandoc -import qualified Text.Pandoc.Writers.Shared as Pandoc +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Traversable (for) +import qualified Data.Yaml as Yaml +import Patat.Presentation.Settings (PresentationSettings) +import qualified Text.Pandoc as Pandoc +import qualified Text.Pandoc.Writers.Shared as Pandoc -- | This is similar to 'Pandoc.Block'. Having our own datatype has some -- advantages: @@ -41,6 +48,9 @@ data Block | Table ![Pandoc.Inline] ![Pandoc.Alignment] ![[Block]] ![[[Block]]] | Figure !Pandoc.Attr ![Block] | Div !Pandoc.Attr ![Block] + -- Our own extensions: + | SpeakerNote !T.Text + | Config !(Either String PresentationSettings) deriving (Eq, Show) -- | Depth-First Traversal of blocks (and inlines). @@ -72,6 +82,8 @@ dftBlock fb fi = (>>= fb) . \case <*> traverse (traverse (traverse block)) trows Figure attr xs -> Figure attr <$> traverse block xs Div attr xs -> Div attr <$> traverse block xs + b@(SpeakerNote _txt) -> pure b + b@(Config _cfg) -> pure b where block = dftBlock fb fi inline = dftInline fb fi @@ -115,7 +127,19 @@ fromPandoc (Pandoc.Plain inlines) = Plain inlines fromPandoc (Pandoc.Para inlines) = Para inlines fromPandoc (Pandoc.LineBlock inliness) = LineBlock inliness fromPandoc (Pandoc.CodeBlock attrs body) = CodeBlock attrs body -fromPandoc (Pandoc.RawBlock fmt body) = RawBlock fmt body +fromPandoc (Pandoc.RawBlock fmt body) + -- Parse config blocks. + | fmt == "html" + , Just t1 <- T.stripPrefix "" t1 = Config $ + case Yaml.decodeEither' (T.encodeUtf8 t2) of + Left err -> Left (show err) + Right obj -> Right obj + -- Parse other comments. + | Just t1 <- T.stripPrefix "" t1 = SpeakerNote $ T.strip t2 + -- Other raw blocks, leave as-is. + | otherwise = RawBlock fmt body fromPandoc (Pandoc.BlockQuote blocks) = BlockQuote $ map fromPandoc blocks fromPandoc (Pandoc.OrderedList attrs items) = @@ -140,3 +164,12 @@ fromPandoc (Pandoc.Figure attrs _caption blocks) = Figure attrs $ map fromPandoc blocks fromPandoc (Pandoc.Div attrs blocks) = Div attrs $ map fromPandoc blocks + +isHorizontalRule :: Block -> Bool +isHorizontalRule HorizontalRule = True +isHorizontalRule _ = False + +isComment :: Block -> Bool +isComment (SpeakerNote _) = True +isComment (Config _) = True +isComment _ = False diff --git a/lib/Patat/Theme.hs b/lib/Patat/Theme.hs index 00491d8..cd75625 100644 --- a/lib/Patat/Theme.hs +++ b/lib/Patat/Theme.hs @@ -57,7 +57,7 @@ data Theme = Theme , themeImageText :: !(Maybe Style) , themeImageTarget :: !(Maybe Style) , themeSyntaxHighlighting :: !(Maybe SyntaxHighlighting) - } deriving (Show) + } deriving (Eq, Show) -------------------------------------------------------------------------------- @@ -138,7 +138,7 @@ defaultTheme = Theme -------------------------------------------------------------------------------- newtype Style = Style {unStyle :: [Ansi.SGR]} - deriving (Monoid, Semigroup, Show) + deriving (Eq, Monoid, Semigroup, Show) -------------------------------------------------------------------------------- @@ -241,7 +241,7 @@ namedSgrs = M.fromList -------------------------------------------------------------------------------- newtype SyntaxHighlighting = SyntaxHighlighting { unSyntaxHighlighting :: M.Map String Style - } deriving (Monoid, Semigroup, Show, A.ToJSON) + } deriving (Eq, Monoid, Semigroup, Show, A.ToJSON) -------------------------------------------------------------------------------- diff --git a/tests/haskell/Patat/Presentation/Read/Tests.hs b/tests/haskell/Patat/Presentation/Read/Tests.hs index cbfc981..39fe79f 100644 --- a/tests/haskell/Patat/Presentation/Read/Tests.hs +++ b/tests/haskell/Patat/Presentation/Read/Tests.hs @@ -60,7 +60,7 @@ testDetectSlideLevel = Tasty.testGroup "detectSlideLevel" , Tasty.testCase "03" $ (Tasty.@=?) 2 $ detectSlideLevel [ Header 1 mempty [Pandoc.Str "Intro"] - , RawBlock "html" "" + , SpeakerNote "Some speaker note" , Header 2 mempty [Pandoc.Str "Detail"] , Para [Pandoc.Str "Hi"] ]