Refactor comments into proper AST nodes

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

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 "<!--config:" t0
-        t2 <- T.stripSuffix "-->" t1
-        pure . Comment mempty $ case Yaml.decodeEither' (T.encodeUtf8 t2) of
-            Left err  -> Left (show err)
-            Right obj -> Right obj) <|>
-    (do
-        t1 <- T.stripPrefix "<!--" t0
-        t2 <- T.stripSuffix "-->" 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 _    _                        -> []

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

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

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
 
 
 --------------------------------------------------------------------------------

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

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)
 
 
 --------------------------------------------------------------------------------