WIP: trigger implementation

lib/Patat/Eval.hs

@@ -11,33 +11,33 @@ module Patat.Eval
 
 
 --------------------------------------------------------------------------------
-import qualified Control.Concurrent.Async       as Async
-import           Control.Exception              (IOException, catch, finally)
-import           Control.Monad                  (foldM, when)
-import           Control.Monad.State            (StateT, runStateT, state)
-import           Control.Monad.Writer           (Writer, runWriter, tell)
-import           Data.Foldable                  (for_)
-import qualified Data.HashMap.Strict            as HMS
-import qualified Data.IORef                     as IORef
-import           Data.List                      (foldl')
-import           Data.Maybe                     (maybeToList)
-import qualified Data.Text                      as T
-import qualified Data.Text.IO                   as T
+import qualified Control.Concurrent.Async    as Async
+import           Control.Exception           (IOException, catch, finally)
+import           Control.Monad               (foldM, when)
+import           Control.Monad.State         (StateT, runStateT, state)
+import           Control.Monad.Writer        (Writer, runWriter, tell)
+import           Data.Foldable               (for_)
+import qualified Data.HashMap.Strict         as HMS
+import qualified Data.IORef                  as IORef
+import           Data.List                   (foldl')
+import           Data.Maybe                  (maybeToList)
+import qualified Data.Set                    as S
+import qualified Data.Text                   as T
+import qualified Data.Text.IO                as T
 import           Patat.Eval.Internal
-import           Patat.Presentation.Instruction
 import           Patat.Presentation.Internal
 import           Patat.Presentation.Syntax
-import           System.Exit                    (ExitCode (..))
-import qualified System.IO                      as IO
-import qualified System.Process                 as Process
+import           System.Exit                 (ExitCode (..))
+import qualified System.IO                   as IO
+import qualified System.Process              as Process
 
 
 --------------------------------------------------------------------------------
 parseEvalBlocks :: Presentation -> Presentation
 parseEvalBlocks presentation =
     let ((pres, varGen), evalBlocks) = runWriter $
-            runStateT work (pVarGen presentation) in
-    pres {pEvalBlocks = evalBlocks, pVarGen = varGen}
+            runStateT work (pUniqueGen presentation) in
+    pres {pEvalBlocks = evalBlocks, pUniqueGen = varGen}
   where
     work = case psEval (pSettings presentation) of
         Nothing -> pure presentation
@@ -56,53 +56,49 @@ lookupSettings classes settings = do
 --------------------------------------------------------------------------------
 -- | Monad used for identifying and extracting the evaluation blocks from a
 -- presentation.
-type ExtractEvalM a = StateT VarGen (Writer (HMS.HashMap Var EvalBlock)) a
+type ExtractEvalM a = StateT UniqueGen (Writer (HMS.HashMap Var EvalBlock)) a
 
 
 --------------------------------------------------------------------------------
 evalSlide :: EvalSettingsMap -> Slide -> ExtractEvalM Slide
 evalSlide settings slide = case slideContent slide of
     TitleSlide _ _ -> pure slide
-    ContentSlide instrs0 -> do
-        instrs1 <- traverse (evalInstruction settings) (toList instrs0)
-        pure slide {slideContent = ContentSlide . fromList $ concat instrs1}
-
-
---------------------------------------------------------------------------------
-evalInstruction
-    :: EvalSettingsMap -> Instruction Block
-    -> ExtractEvalM [Instruction Block]
-evalInstruction settings instr = case instr of
-    Pause         -> pure [Pause]
-    ModifyLast i  -> map ModifyLast <$> evalInstruction settings i
-    Append []     -> pure [Append []]
-    Append blocks -> concat <$> traverse (evalBlock settings) blocks
-    Delete        -> pure [Delete]
+    ContentSlide blocks -> do
+        blocks1 <- dftBlocks (evalBlock settings) (pure . pure) blocks
+        pure slide {slideContent = ContentSlide blocks1}
 
 
 --------------------------------------------------------------------------------
 evalBlock
     :: EvalSettingsMap -> Block
-    -> ExtractEvalM [Instruction Block]
+    -> ExtractEvalM [Block]
 evalBlock settings orig@(CodeBlock attr@(_, classes, _) txt)
     | [s@EvalSettings {..}] <- lookupSettings classes settings = do
-        var <- state freshVar
+        var <- Var <$> state freshUnique
         tell $ HMS.singleton var $ EvalBlock s attr txt Nothing
-        pure $ case (evalFragment, evalReplace) of
-            (False, True) -> [Append [VarBlock var]]
-            (False, False) -> [Append [orig, VarBlock var]]
-            (True, True) ->
-                [ Append [orig], Pause
-                , Delete, Append [VarBlock var]
-                ]
-            (True, False) ->
-                [Append [orig], Pause, Append [VarBlock var]]
+        case (evalFragment, evalReplace) of
+            (False, True) -> pure [VarBlock var]
+            (False, False) -> pure [orig, VarBlock var]
+            (True, True) -> do
+                counterID <- CounterID <$> state freshUnique
+                pure $ pure $ Fragmented (FragmentWrapper concat) $ Fragment2
+                    counterID
+                    [counterID]
+                    [(S.singleton 0, [orig]), (S.singleton 1, [VarBlock var])]
+            (True, False) -> do
+                counterID <- CounterID <$> state freshUnique
+                pure $ pure $ Fragmented (FragmentWrapper concat) $ Fragment2
+                    counterID
+                    [counterID]
+                    [ (S.fromList [0, 1], [orig])
+                    , (S.fromList [1], [VarBlock var])
+                    ]
     | _ : _ : _ <- lookupSettings classes settings =
         let msg = "patat eval matched multiple settings for " <>
                 T.intercalate "," classes in
-        pure [Append [CodeBlock attr msg]]
+        pure [CodeBlock attr msg]
 evalBlock _ block =
-    pure [Append [block]]
+    pure [block]
 
 
 --------------------------------------------------------------------------------

lib/Patat/Eval/Internal.hs

@@ -11,7 +11,6 @@ module Patat.Eval.Internal
 import qualified Control.Concurrent.Async       as Async
 import qualified Data.HashMap.Strict            as HMS
 import qualified Data.Text                      as T
-import           Patat.Presentation.Instruction
 import           Patat.Presentation.Settings
 import           Patat.Presentation.Syntax
 import qualified Text.Pandoc                    as Pandoc

lib/Patat/Main.hs

@@ -161,7 +161,7 @@ main = do
             OA.parserFailure parserPrefs parserInfo
             (OA.ShowHelpText Nothing) mempty
 
-    errOrPres <- readPresentation zeroVarGen filePath
+    errOrPres <- readPresentation zeroUniqueGen filePath
     pres      <- either (errorAndExit . return) return errOrPres
     let settings = pSettings pres
 

lib/Patat/Presentation.hs

@@ -2,9 +2,9 @@ module Patat.Presentation
     ( PresentationSettings (..)
     , defaultPresentationSettings
 
-    , VarGen
-    , Var
-    , zeroVarGen
+    , UniqueGen
+    , Unique
+    , zeroUniqueGen
 
     , Presentation (..)
     , readPresentation
@@ -27,7 +27,7 @@ module Patat.Presentation
     ) where
 
 import           Patat.Presentation.Display
-import           Patat.Presentation.Instruction
 import           Patat.Presentation.Interactive
 import           Patat.Presentation.Internal
 import           Patat.Presentation.Read
+import           Patat.Presentation.Syntax

lib/Patat/Presentation/Display.hs

@@ -55,21 +55,26 @@ 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 <>
+    -- TODO:
+    -- PP.string (show $ dsCounters ds) <> PP.hardline <>
+    -- PP.string (show $ activeTriggers pres) <> PP.hardline <>
+    -- PP.string (show $ pSlides ) <> 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.
@@ -118,14 +123,13 @@ displayPresentation size pres@Presentation {..} =
         Just (ActiveTitle block) -> DisplayDoc $
             displayWithBorders size pres $ \ds ->
                 let auto = Margins {mTop = Auto, mRight = Auto, mLeft = Auto} in
-                prettyFragment ds {dsMargins = auto} $ Fragment [block]
-
+                prettyFragment ds {dsMargins = auto} [block]
   where
     -- Check if the fragment consists of "just a single image".  Discard
     -- headers.
-    onlyImage (Fragment (Header{} : bs)) = onlyImage (Fragment bs)
-    onlyImage (Fragment bs) = case bs of
-        [Figure _ bs']                 -> onlyImage (Fragment bs')
+    onlyImage (Header{} : bs) = onlyImage bs
+    onlyImage bs = case bs of
+        [Figure _ bs']                 -> onlyImage bs'
         [Para [Image _ _ (target, _)]] -> Just target
         _                              -> Nothing
 
@@ -176,8 +180,8 @@ dumpPresentation pres@Presentation {..} =
 
 
 --------------------------------------------------------------------------------
-prettyFragment :: DisplaySettings -> Fragment -> PP.Doc
-prettyFragment ds (Fragment blocks) = vertical $
+prettyFragment :: DisplaySettings -> [Block] -> PP.Doc
+prettyFragment ds blocks = vertical $
     PP.vcat (map (horizontal . prettyBlock ds) blocks) <>
     case prettyReferences ds blocks of
         []   -> mempty
@@ -323,7 +327,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
     }