WIP: trigger implementation

lib/Patat/Eval.hs

@@ -64,7 +64,7 @@ evalSlide :: EvalSettingsMap -> Slide -> ExtractEvalM Slide
 evalSlide settings slide = case slideContent slide of
     TitleSlide _ _ -> pure slide
     ContentSlide instrs0 -> do
-        instrs1 <- traverse (evalInstruction settings) (toList instrs0)
+        instrs1 <- traverse (evalInstruction settings) (unInstructions instrs0)
         pure slide {slideContent = ContentSlide . fromList $ concat instrs1}
 
 

lib/Patat/Presentation/Display.hs

@@ -55,21 +55,23 @@ displayWithBorders (Size rows columns) pres@Presentation {..} f =
                 wrappedTitle = PP.spaces titleOffset <> PP.string title <> PP.spaces titleRemainder in
         borders wrappedTitle <> PP.hardline) <>
     f ds <> PP.hardline <>
+    PP.string (show $ dsCounters ds) <> PP.hardline <>
     PP.goToLine (rows - 2) <>
     borders (PP.space <> PP.string author <> middleSpaces <> PP.string active <> PP.space) <>
     PP.hardline
   where
     -- Get terminal width/title
-    (sidx, _) = pActiveFragment
-    settings  = activeSettings pres
-    ds        = DisplaySettings
+    (sidx, fidx) = pActiveFragment
+    settings     = activeSettings pres
+    ds           = DisplaySettings
         { dsSize          = canvasSize
         , dsMargins       = margins settings
         , dsWrap          = fromMaybe NoWrap $ psWrap settings
         , dsTabStop       = maybe 4 A.unFlexibleNum $ psTabStop settings
         , dsTheme         = fromMaybe Theme.defaultTheme (psTheme settings)
         , dsSyntaxMap     = pSyntaxMap
         , dsResolve       = \var -> fromMaybe [] $ HMS.lookup var pVars
+        , dsCounters      = triggersToCounters $ take fidx $ activeTriggers pres
         }
 
     -- Compute title.
@@ -323,7 +325,11 @@ prettyBlock ds (LineBlock inliness) =
 
 prettyBlock ds (Figure _attr blocks) = prettyBlocks ds blocks
 
+prettyBlock ds (Fragmented w fragment) = prettyBlocks ds $
+    fragmentToBlocks (dsCounters ds) w fragment
+
 prettyBlock ds (VarBlock var) = prettyBlocks ds $ dsResolve ds var
+
 prettyBlock _ (SpeakerNote _) = mempty
 prettyBlock _ (Config _) = mempty
 

lib/Patat/Presentation/Display/Internal.hs

@@ -8,7 +8,7 @@ module Patat.Presentation.Display.Internal
 --------------------------------------------------------------------------------
 import           Patat.Presentation.Internal (Margins)
 import           Patat.Presentation.Settings (Wrap)
-import           Patat.Presentation.Syntax   (Block, Var)
+import           Patat.Presentation.Syntax   (Block, Counters, Var)
 import qualified Patat.PrettyPrint           as PP
 import           Patat.Size                  (Size)
 import qualified Patat.Theme                 as Theme
@@ -24,6 +24,7 @@ data DisplaySettings = DisplaySettings
     , dsTheme     :: !Theme.Theme
     , dsSyntaxMap :: !Skylighting.SyntaxMap
     , dsResolve   :: !(Var -> [Block])
+    , dsCounters  :: !Counters
     }
 
 

lib/Patat/Presentation/Fragment.hs

@@ -14,7 +14,9 @@ module Patat.Presentation.Fragment
     ) where
 
 import           Data.List                      (intersperse, intercalate)
+import qualified Data.Set as S
 import           Patat.Presentation.Instruction
+import Data.Foldable (toList)
 import           Patat.Presentation.Syntax
 import           Prelude
 
@@ -25,36 +27,65 @@ data FragmentSettings = FragmentSettings
 fragmentInstructions
     :: FragmentSettings
     -> Instructions Block -> Instructions Block
-fragmentInstructions fs = fromList . concatMap fragmentInstruction . toList
+fragmentInstructions fs =
+    fromList . foldMap fragmentInstruction . unInstructions
   where
     fragmentInstruction Pause = [Pause]
     fragmentInstruction (Append []) = [Append []]
     fragmentInstruction (Append xs) = fragmentBlocks fs xs
     fragmentInstruction Delete = [Delete]
     fragmentInstruction (ModifyLast f) = map ModifyLast $ fragmentInstruction f
 
+splitOnThreeDots :: [Block] -> [[Block]]
+splitOnThreeDots blocks = case break (== threeDots) blocks of
+    (pre, _ : post) -> [pre] ++ splitOnThreeDots post
+    (pre, [])       -> [pre]
+  where
+    threeDots = Para $ intersperse Space $ replicate 3 (Str ".")
+
 fragmentBlocks
     :: FragmentSettings -> [Block] -> [Instruction Block]
-fragmentBlocks = concatMap . fragmentBlock
+fragmentBlocks fs blocks = case splitOnThreeDots blocks of
+    [] -> []
+    [_] -> concatMap (fragmentBlock fs) blocks
+    sections@(sh : st) ->
+        pure $ Append $ pure $ Fragmented (FragmentWrapper concat) $ Fragment2
+            counterID
+            triggers
+            [(S.fromList [i .. pauses], s) | (i, s) <- zip [0 ..] sections]
+      where
+        counterID = freshCounterID $ blocksFreshCounterID blocks
+        pauses    = length sections - 1
+        triggers  = blocksTriggers sh ++
+            [c | s <- st, c <- counterID : blocksTriggers s]
+
 
+fragmentBlock :: FragmentSettings -> Block -> [Instruction Block]
+fragmentBlock _fs (Para inlines) = [Append [Para inlines]]
+{-
 fragmentBlock :: FragmentSettings -> Block -> [Instruction Block]
 fragmentBlock _fs block@(Para inlines)
     | inlines == threeDots = [Pause]
     | otherwise            = [Append [block]]
   where
     threeDots = intersperse Space $ replicate 3 (Str ".")
+-}
 
 fragmentBlock fs (BulletList bs0) =
-    fragmentList fs (fsIncrementalLists fs) BulletList bs0
+    pure $ Append $
+    fragmentList2 fs (fsIncrementalLists fs) BulletList bs0
 
 fragmentBlock fs (OrderedList attr bs0) =
-    fragmentList fs (fsIncrementalLists fs) (OrderedList attr) bs0
+    pure $ Append $
+    fragmentList2 fs (fsIncrementalLists fs) (OrderedList attr) bs0
 
 fragmentBlock fs (BlockQuote [BulletList bs0]) =
-    fragmentList fs (not $ fsIncrementalLists fs) BulletList bs0
+    pure $ Append $
+    fragmentList2 fs (not $ fsIncrementalLists fs) BulletList bs0
 
 fragmentBlock fs (BlockQuote [OrderedList attr bs0]) =
-    fragmentList fs (not $ fsIncrementalLists fs) (OrderedList attr) bs0
+    pure $ Append $
+    fragmentList2 fs (not $ fsIncrementalLists fs) (OrderedList attr) bs0
 
 fragmentBlock _ block@(BlockQuote {})     = [Append [block]]
 
@@ -94,3 +125,27 @@ fragmentList fs fragmentThisList constructor items =
         Append [] :
         -- Modify this new item to add the content.
         map ModifyLast (fragmentBlocks fs item)
+
+fragmentList2
+    :: FragmentSettings      -- ^ Global settings
+    -> Bool                  -- ^ Fragment THIS list?
+    -> ([[Block]] -> Block)  -- ^ List constructor
+    -> [[Block]]             -- ^ List items
+    -> [Block]               -- ^ Resulting list
+fragmentList2 fs fragmentThisList constructor items
+    | not fragmentThisList = [constructor items']
+    | otherwise = pure $ Fragmented (FragmentWrapper (pure . constructor)) $
+        Fragment2
+            counterID
+            triggers
+            [(S.fromList [i .. pauses], s) | (i, s) <- zip [1 ..] items']
+  where
+    items' :: [[Block]]
+    items' = do
+        item <- items
+        pure $ concatMap toList $ fragmentBlocks fs item
+
+    counterID = freshCounterID $ blocksFreshCounterID $ concat items'
+    pauses    = length items'
+    triggers  =
+        [c | s <- items', c <- counterID : blocksTriggers s]

lib/Patat/Presentation/Instruction.hs

@@ -4,11 +4,13 @@
 --
 -- We do this by modelling a slide as a list of instructions, that manipulate
 -- the contents on a slide in a (for now) very basic way.
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Patat.Presentation.Instruction
     ( Instructions
+    , unInstructions
     , fromList
-    , toList
 
     , Var
     , VarGen
@@ -27,7 +29,7 @@ import           Data.List                 (foldl')
 import           Patat.Presentation.Syntax
 
 newtype Instructions a = Instructions {unInstructions :: [Instruction a]}
-    deriving (Show)
+    deriving (Functor, Foldable, Show)
 
 -- A smart constructor that guarantees some invariants:
 --
@@ -42,9 +44,6 @@ fromList = Instructions . go
         (_ : _, remainder)  -> Pause : go remainder
         ([], x : remainder) -> x : go remainder
 
-toList :: Instructions a -> [Instruction a]
-toList (Instructions xs) = xs
-
 data Instruction a
     -- Pause.
     = Pause
@@ -54,7 +53,7 @@ data Instruction a
     | Delete
     -- Modify the last block with the provided instruction.
     | ModifyLast (Instruction a)
-    deriving (Show)
+    deriving (Functor, Foldable, Show)
 
 isPause :: Instruction a -> Bool
 isPause Pause          = True

lib/Patat/Presentation/Internal.hs

@@ -32,6 +32,7 @@ module Patat.Presentation.Internal
     , activeFragment
     , activeSpeakerNotes
     , activeVars
+    , activeTriggers
 
     , getSettings
     , activeSettings
@@ -50,6 +51,7 @@ import qualified Data.HashSet                   as HS
 import           Data.Maybe                     (fromMaybe)
 import           Data.Sequence.Extended         (Seq)
 import qualified Data.Sequence.Extended         as Seq
+import Data.Foldable (toList)
 import           Patat.EncodingFallback         (EncodingFallback)
 import qualified Patat.Eval.Internal            as Eval
 import qualified Patat.Presentation.Comments    as Comments
@@ -135,7 +137,10 @@ getSlide sidx = (`Seq.safeIndex` sidx) . pSlides
 --------------------------------------------------------------------------------
 numFragments :: Slide -> Int
 numFragments slide = case slideContent slide of
-    ContentSlide instrs -> Instruction.numFragments instrs
+    ContentSlide instrs ->
+        -- Instruction.numFragments instrs
+        let blocks = toList instrs in
+        1 + length (blocksTriggers blocks)
     TitleSlide _ _      -> 1
 
 
@@ -184,6 +189,22 @@ activeVars presentation = fromMaybe HS.empty $ do
     resolve _ = []
 
 
+--------------------------------------------------------------------------------
+-- TODO: its weird??
+activeTriggers :: Presentation -> [CounterID]
+activeTriggers presentation = fromMaybe [] $ do
+    let (sidx, fidx) = pActiveFragment presentation
+    slide <- getSlide sidx presentation
+    case slideContent slide of
+        TitleSlide _ _ -> Nothing
+        ContentSlide instrs -> pure $
+            blocksTriggers $ Instruction.unFragment $
+            Instruction.renderFragment resolve $
+            Instruction.beforePause fidx instrs
+  where
+    resolve _ = []
+
+
 --------------------------------------------------------------------------------
 getSettings :: Int -> Presentation -> PresentationSettings
 getSettings sidx pres =