summaryrefslogtreecommitdiff
path: root/lib/Patat/Presentation
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Patat/Presentation')
-rw-r--r--lib/Patat/Presentation/Display.hs380
-rw-r--r--lib/Patat/Presentation/Display/CodeBlock.hs83
-rw-r--r--lib/Patat/Presentation/Display/Table.hs107
-rw-r--r--lib/Patat/Presentation/Fragment.hs134
-rw-r--r--lib/Patat/Presentation/Interactive.hs142
-rw-r--r--lib/Patat/Presentation/Internal.hs266
-rw-r--r--lib/Patat/Presentation/Read.hs205
7 files changed, 1317 insertions, 0 deletions
diff --git a/lib/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs
new file mode 100644
index 0000000..876311d
--- /dev/null
+++ b/lib/Patat/Presentation/Display.hs
@@ -0,0 +1,380 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Display
+ ( displayPresentation
+ , displayPresentationError
+ , dumpPresentation
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Applicative ((<$>))
+import Control.Monad (mplus, unless)
+import qualified Data.Aeson.Extended as A
+import Data.Data.Extended (grecQ)
+import qualified Data.List as L
+import Data.Maybe (fromMaybe)
+import Data.Monoid (mconcat, mempty, (<>))
+import qualified Data.Text as T
+import Patat.Cleanup
+import qualified Patat.Images as Images
+import Patat.Presentation.Display.CodeBlock
+import Patat.Presentation.Display.Table
+import Patat.Presentation.Internal
+import Patat.PrettyPrint ((<$$>), (<+>))
+import qualified Patat.PrettyPrint as PP
+import Patat.Theme (Theme (..))
+import qualified Patat.Theme as Theme
+import Prelude
+import qualified System.Console.ANSI as Ansi
+import qualified System.Console.Terminal.Size as Terminal
+import qualified System.IO as IO
+import qualified Text.Pandoc.Extended as Pandoc
+
+
+--------------------------------------------------------------------------------
+data CanvasSize = CanvasSize {csRows :: Int, csCols :: Int} deriving (Show)
+
+
+--------------------------------------------------------------------------------
+-- | Display something within the presentation borders that draw the title and
+-- the active slide number and so on.
+displayWithBorders
+ :: Presentation -> (CanvasSize -> Theme -> PP.Doc) -> IO Cleanup
+displayWithBorders Presentation {..} f = do
+ Ansi.clearScreen
+ Ansi.setCursorPosition 0 0
+
+ -- Get terminal width/title
+ mbWindow <- Terminal.size
+ let columns = fromMaybe 72 $
+ (A.unFlexibleNum <$> psColumns pSettings) `mplus`
+ (Terminal.width <$> mbWindow)
+ rows = fromMaybe 24 $
+ (A.unFlexibleNum <$> psRows pSettings) `mplus`
+ (Terminal.height <$> mbWindow)
+
+ let settings = pSettings {psColumns = Just $ A.FlexibleNum columns}
+ theme = fromMaybe Theme.defaultTheme (psTheme settings)
+ title = PP.toString (prettyInlines theme pTitle)
+ titleWidth = length title
+ titleOffset = (columns - titleWidth) `div` 2
+ borders = themed (themeBorders theme)
+
+ unless (null title) $ do
+ let titleRemainder = columns - titleWidth - titleOffset
+ wrappedTitle = PP.spaces titleOffset <> PP.string title <> PP.spaces titleRemainder
+ PP.putDoc $ borders wrappedTitle
+ putStrLn ""
+ putStrLn ""
+
+ let canvasSize = CanvasSize (rows - 2) columns
+ PP.putDoc $ formatWith settings $ f canvasSize theme
+ putStrLn ""
+
+ let (sidx, _) = pActiveFragment
+ active = show (sidx + 1) ++ " / " ++ show (length pSlides)
+ activeWidth = length active
+ author = PP.toString (prettyInlines theme pAuthor)
+ authorWidth = length author
+ middleSpaces = PP.spaces $ columns - activeWidth - authorWidth - 2
+
+ Ansi.setCursorPosition (rows - 1) 0
+ PP.putDoc $ borders $ PP.space <> PP.string author <> middleSpaces <> PP.string active <> PP.space
+ IO.hFlush IO.stdout
+
+ return mempty
+
+
+--------------------------------------------------------------------------------
+displayImage :: Images.Handle -> FilePath -> IO Cleanup
+displayImage images path = do
+ Ansi.clearScreen
+ Ansi.setCursorPosition 0 0
+ putStrLn ""
+ IO.hFlush IO.stdout
+ Images.drawImage images path
+
+
+--------------------------------------------------------------------------------
+displayPresentation :: Maybe Images.Handle -> Presentation -> IO Cleanup
+displayPresentation mbImages pres@Presentation {..} =
+ case getActiveFragment pres of
+ Nothing -> displayWithBorders pres mempty
+ Just (ActiveContent fragment)
+ | Just images <- mbImages
+ , Just image <- onlyImage fragment ->
+ displayImage images image
+ Just (ActiveContent fragment) ->
+ displayWithBorders pres $ \_canvasSize theme ->
+ prettyFragment theme fragment
+ Just (ActiveTitle block) ->
+ displayWithBorders pres $ \canvasSize theme ->
+ let pblock = prettyBlock theme block
+ (prows, pcols) = PP.dimensions pblock
+ (mLeft, mRight) = marginsOf pSettings
+ offsetRow = (csRows canvasSize `div` 2) - (prows `div` 2)
+ offsetCol = ((csCols canvasSize - mLeft - mRight) `div` 2) - (pcols `div` 2)
+ spaces = PP.NotTrimmable $ PP.spaces offsetCol in
+ mconcat (replicate (offsetRow - 3) PP.hardline) <$$>
+ PP.indent spaces spaces pblock
+
+ where
+ -- Check if the fragment consists of just a single image, or a header and
+ -- some image.
+ onlyImage (Fragment blocks)
+ | [Pandoc.Para para] <- filter isVisibleBlock blocks
+ , [Pandoc.Image _ _ (target, _)] <- para =
+ Just target
+ onlyImage (Fragment blocks)
+ | [Pandoc.Header _ _ _, Pandoc.Para para] <- filter isVisibleBlock blocks
+ , [Pandoc.Image _ _ (target, _)] <- para =
+ Just target
+ onlyImage _ = Nothing
+
+
+--------------------------------------------------------------------------------
+-- | Displays an error in the place of the presentation. This is useful if we
+-- want to display an error but keep the presentation running.
+displayPresentationError :: Presentation -> String -> IO Cleanup
+displayPresentationError pres err = displayWithBorders pres $ \_ Theme {..} ->
+ themed themeStrong "Error occurred in the presentation:" <$$>
+ "" <$$>
+ (PP.string err)
+
+
+--------------------------------------------------------------------------------
+dumpPresentation :: Presentation -> IO ()
+dumpPresentation pres =
+ let settings = pSettings pres
+ theme = fromMaybe Theme.defaultTheme (psTheme $ settings) in
+ PP.putDoc $ formatWith settings $
+ PP.vcat $ L.intersperse "----------" $ do
+ slide <- pSlides pres
+ return $ case slide of
+ TitleSlide block -> "~~~title" <$$> prettyBlock theme block
+ ContentSlide fragments -> PP.vcat $ L.intersperse "~~~frag" $ do
+ fragment <- fragments
+ return $ prettyFragment theme fragment
+
+
+--------------------------------------------------------------------------------
+formatWith :: PresentationSettings -> PP.Doc -> PP.Doc
+formatWith ps = wrap . indent
+ where
+ (marginLeft, marginRight) = marginsOf ps
+ wrap = case (psWrap ps, psColumns ps) of
+ (Just True, Just (A.FlexibleNum col)) -> PP.wrapAt (Just $ col - marginRight)
+ _ -> id
+ spaces = PP.NotTrimmable $ PP.spaces marginLeft
+ indent = PP.indent spaces spaces
+
+--------------------------------------------------------------------------------
+prettyFragment :: Theme -> Fragment -> PP.Doc
+prettyFragment theme fragment@(Fragment blocks) =
+ prettyBlocks theme blocks <>
+ case prettyReferences theme fragment of
+ [] -> mempty
+ refs -> PP.hardline <> PP.vcat refs
+
+
+--------------------------------------------------------------------------------
+prettyBlock :: Theme -> Pandoc.Block -> PP.Doc
+
+prettyBlock theme (Pandoc.Plain inlines) = prettyInlines theme inlines
+
+prettyBlock theme (Pandoc.Para inlines) =
+ prettyInlines theme inlines <> PP.hardline
+
+prettyBlock theme@Theme {..} (Pandoc.Header i _ inlines) =
+ themed themeHeader (PP.string (replicate i '#') <+> prettyInlines theme inlines) <>
+ PP.hardline
+
+prettyBlock theme (Pandoc.CodeBlock (_, classes, _) txt) =
+ prettyCodeBlock theme classes txt
+
+prettyBlock theme (Pandoc.BulletList bss) = PP.vcat
+ [ PP.indent
+ (PP.NotTrimmable $ themed (themeBulletList theme) prefix)
+ (PP.Trimmable " ")
+ (prettyBlocks theme' bs)
+ | bs <- bss
+ ] <> PP.hardline
+ where
+ prefix = " " <> PP.string [marker] <> " "
+ marker = case T.unpack <$> themeBulletListMarkers theme of
+ Just (x : _) -> x
+ _ -> '-'
+
+ -- Cycle the markers.
+ theme' = theme
+ { themeBulletListMarkers =
+ (\ls -> T.drop 1 ls <> T.take 1 ls) <$> themeBulletListMarkers theme
+ }
+
+prettyBlock theme@Theme {..} (Pandoc.OrderedList _ bss) = PP.vcat
+ [ PP.indent
+ (PP.NotTrimmable $ themed themeOrderedList $ PP.string prefix)
+ (PP.Trimmable " ")
+ (prettyBlocks theme bs)
+ | (prefix, bs) <- zip padded bss
+ ] <> PP.hardline
+ where
+ padded = [n ++ replicate (4 - length n) ' ' | n <- numbers]
+ numbers =
+ [ show i ++ "."
+ | i <- [1 .. length bss]
+ ]
+
+prettyBlock _theme (Pandoc.RawBlock _ t) = PP.string t <> PP.hardline
+
+prettyBlock _theme Pandoc.HorizontalRule = "---"
+
+prettyBlock theme@Theme {..} (Pandoc.BlockQuote bs) =
+ let quote = PP.NotTrimmable (themed themeBlockQuote "> ") in
+ PP.indent quote quote (prettyBlocks theme bs)
+
+prettyBlock theme@Theme {..} (Pandoc.DefinitionList terms) =
+ PP.vcat $ map prettyDefinition terms
+ where
+ prettyDefinition (term, definitions) =
+ themed themeDefinitionTerm (prettyInlines theme term) <$$>
+ PP.hardline <> PP.vcat
+ [ PP.indent
+ (PP.NotTrimmable (themed themeDefinitionList ": "))
+ (PP.Trimmable " ") $
+ prettyBlocks theme (Pandoc.plainToPara definition)
+ | definition <- definitions
+ ]
+
+prettyBlock theme (Pandoc.Table caption aligns _ headers rows) =
+ PP.wrapAt Nothing $
+ prettyTable theme Table
+ { tCaption = prettyInlines theme caption
+ , tAligns = map align aligns
+ , tHeaders = map (prettyBlocks theme) headers
+ , tRows = map (map (prettyBlocks theme)) rows
+ }
+ where
+ align Pandoc.AlignLeft = PP.AlignLeft
+ align Pandoc.AlignCenter = PP.AlignCenter
+ align Pandoc.AlignDefault = PP.AlignLeft
+ align Pandoc.AlignRight = PP.AlignRight
+
+prettyBlock theme (Pandoc.Div _attrs blocks) = prettyBlocks theme blocks
+
+prettyBlock _theme Pandoc.Null = mempty
+
+#if MIN_VERSION_pandoc(1,18,0)
+-- 'LineBlock' elements are new in pandoc-1.18
+prettyBlock theme@Theme {..} (Pandoc.LineBlock inliness) =
+ let ind = PP.NotTrimmable (themed themeLineBlock "| ") in
+ PP.wrapAt Nothing $
+ PP.indent ind ind $
+ PP.vcat $
+ map (prettyInlines theme) inliness
+#endif
+
+
+--------------------------------------------------------------------------------
+prettyBlocks :: Theme -> [Pandoc.Block] -> PP.Doc
+prettyBlocks theme = PP.vcat . map (prettyBlock theme) . filter isVisibleBlock
+
+
+--------------------------------------------------------------------------------
+prettyInline :: Theme -> Pandoc.Inline -> PP.Doc
+
+prettyInline _theme Pandoc.Space = PP.space
+
+prettyInline _theme (Pandoc.Str str) = PP.string str
+
+prettyInline theme@Theme {..} (Pandoc.Emph inlines) =
+ themed themeEmph $
+ prettyInlines theme inlines
+
+prettyInline theme@Theme {..} (Pandoc.Strong inlines) =
+ themed themeStrong $
+ prettyInlines theme inlines
+
+prettyInline Theme {..} (Pandoc.Code _ txt) =
+ themed themeCode $
+ PP.string (" " <> txt <> " ")
+
+prettyInline theme@Theme {..} link@(Pandoc.Link _attrs text (target, _title))
+ | isReferenceLink link =
+ "[" <> themed themeLinkText (prettyInlines theme text) <> "]"
+ | otherwise =
+ "<" <> themed themeLinkTarget (PP.string target) <> ">"
+
+prettyInline _theme Pandoc.SoftBreak = PP.softline
+
+prettyInline _theme Pandoc.LineBreak = PP.hardline
+
+prettyInline theme@Theme {..} (Pandoc.Strikeout t) =
+ "~~" <> themed themeStrikeout (prettyInlines theme t) <> "~~"
+
+prettyInline theme@Theme {..} (Pandoc.Quoted Pandoc.SingleQuote t) =
+ "'" <> themed themeQuoted (prettyInlines theme t) <> "'"
+prettyInline theme@Theme {..} (Pandoc.Quoted Pandoc.DoubleQuote t) =
+ "'" <> themed themeQuoted (prettyInlines theme t) <> "'"
+
+prettyInline Theme {..} (Pandoc.Math _ t) =
+ themed themeMath (PP.string t)
+
+prettyInline theme@Theme {..} (Pandoc.Image _attrs text (target, _title)) =
+ "![" <> themed themeImageText (prettyInlines theme text) <> "](" <>
+ themed themeImageTarget (PP.string target) <> ")"
+
+-- These elements aren't really supported.
+prettyInline theme (Pandoc.Cite _ t) = prettyInlines theme t
+prettyInline theme (Pandoc.Span _ t) = prettyInlines theme t
+prettyInline _theme (Pandoc.RawInline _ t) = PP.string t
+prettyInline theme (Pandoc.Note t) = prettyBlocks theme t
+prettyInline theme (Pandoc.Superscript t) = prettyInlines theme t
+prettyInline theme (Pandoc.Subscript t) = prettyInlines theme t
+prettyInline theme (Pandoc.SmallCaps t) = prettyInlines theme t
+-- prettyInline unsupported = PP.ondullred $ PP.string $ show unsupported
+
+
+--------------------------------------------------------------------------------
+prettyInlines :: Theme -> [Pandoc.Inline] -> PP.Doc
+prettyInlines theme = mconcat . map (prettyInline theme)
+
+
+--------------------------------------------------------------------------------
+prettyReferences :: Theme -> Fragment -> [PP.Doc]
+prettyReferences theme@Theme {..} =
+ map prettyReference . getReferences . unFragment
+ where
+ getReferences :: [Pandoc.Block] -> [Pandoc.Inline]
+ getReferences = filter isReferenceLink . grecQ
+
+ prettyReference :: Pandoc.Inline -> PP.Doc
+ prettyReference (Pandoc.Link _attrs text (target, title)) =
+ "[" <>
+ themed themeLinkText (prettyInlines theme $ Pandoc.newlineToSpace text) <>
+ "](" <>
+ themed themeLinkTarget (PP.string target) <>
+ (if null title
+ then mempty
+ else PP.space <> "\"" <> PP.string title <> "\"")
+ <> ")"
+ prettyReference _ = mempty
+
+
+--------------------------------------------------------------------------------
+isReferenceLink :: Pandoc.Inline -> Bool
+isReferenceLink (Pandoc.Link _attrs text (target, _)) =
+ [Pandoc.Str target] /= text
+isReferenceLink _ = False
+
+
+--------------------------------------------------------------------------------
+isVisibleBlock :: Pandoc.Block -> Bool
+isVisibleBlock Pandoc.Null = False
+isVisibleBlock (Pandoc.RawBlock (Pandoc.Format "html") t) =
+ not ("<!--" `L.isPrefixOf` t && "-->" `L.isSuffixOf` t)
+isVisibleBlock _ = True
diff --git a/lib/Patat/Presentation/Display/CodeBlock.hs b/lib/Patat/Presentation/Display/CodeBlock.hs
new file mode 100644
index 0000000..149bc68
--- /dev/null
+++ b/lib/Patat/Presentation/Display/CodeBlock.hs
@@ -0,0 +1,83 @@
+--------------------------------------------------------------------------------
+-- | Displaying code blocks, optionally with syntax highlighting.
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Display.CodeBlock
+ ( prettyCodeBlock
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Maybe (mapMaybe)
+import Data.Monoid (mconcat, (<>))
+import qualified Data.Text as T
+import Patat.Presentation.Display.Table (themed)
+import qualified Patat.PrettyPrint as PP
+import Patat.Theme
+import Prelude
+import qualified Skylighting as Skylighting
+
+
+--------------------------------------------------------------------------------
+highlight :: [String] -> String -> [Skylighting.SourceLine]
+highlight classes rawCodeBlock = case mapMaybe getSyntax classes of
+ [] -> zeroHighlight rawCodeBlock
+ (syn : _) ->
+ case Skylighting.tokenize config syn (T.pack rawCodeBlock) of
+ Left _ -> zeroHighlight rawCodeBlock
+ Right sl -> sl
+ where
+ getSyntax :: String -> Maybe Skylighting.Syntax
+ getSyntax c = Skylighting.lookupSyntax (T.pack c) syntaxMap
+
+ config :: Skylighting.TokenizerConfig
+ config = Skylighting.TokenizerConfig
+ { Skylighting.syntaxMap = syntaxMap
+ , Skylighting.traceOutput = False
+ }
+
+ syntaxMap :: Skylighting.SyntaxMap
+ syntaxMap = Skylighting.defaultSyntaxMap
+
+
+--------------------------------------------------------------------------------
+-- | This does fake highlighting, everything becomes a normal token. That makes
+-- things a bit easier, since we only need to deal with one cases in the
+-- renderer.
+zeroHighlight :: String -> [Skylighting.SourceLine]
+zeroHighlight str =
+ [[(Skylighting.NormalTok, T.pack line)] | line <- lines str]
+
+
+--------------------------------------------------------------------------------
+prettyCodeBlock :: Theme -> [String] -> String -> PP.Doc
+prettyCodeBlock theme@Theme {..} classes rawCodeBlock =
+ PP.vcat (map blockified sourceLines) <>
+ PP.hardline
+ where
+ sourceLines :: [Skylighting.SourceLine]
+ sourceLines =
+ [[]] ++ highlight classes rawCodeBlock ++ [[]]
+
+ prettySourceLine :: Skylighting.SourceLine -> PP.Doc
+ prettySourceLine = mconcat . map prettyToken
+
+ prettyToken :: Skylighting.Token -> PP.Doc
+ prettyToken (tokenType, str) =
+ themed (syntaxHighlight theme tokenType) (PP.string $ T.unpack str)
+
+ sourceLineLength :: Skylighting.SourceLine -> Int
+ sourceLineLength line = sum [T.length str | (_, str) <- line]
+
+ blockWidth :: Int
+ blockWidth = foldr max 0 (map sourceLineLength sourceLines)
+
+ blockified :: Skylighting.SourceLine -> PP.Doc
+ blockified line =
+ let len = sourceLineLength line
+ indent = PP.NotTrimmable " " in
+ PP.indent indent indent $
+ themed themeCodeBlock $
+ " " <>
+ prettySourceLine line <>
+ PP.string (replicate (blockWidth - len) ' ') <> " "
diff --git a/lib/Patat/Presentation/Display/Table.hs b/lib/Patat/Presentation/Display/Table.hs
new file mode 100644
index 0000000..fee68c9
--- /dev/null
+++ b/lib/Patat/Presentation/Display/Table.hs
@@ -0,0 +1,107 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Display.Table
+ ( Table (..)
+ , prettyTable
+
+ , themed
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.List (intersperse, transpose)
+import Data.Monoid (mconcat, mempty, (<>))
+import Patat.PrettyPrint ((<$$>))
+import qualified Patat.PrettyPrint as PP
+import Patat.Theme (Theme (..))
+import qualified Patat.Theme as Theme
+import Prelude
+
+
+--------------------------------------------------------------------------------
+data Table = Table
+ { tCaption :: PP.Doc
+ , tAligns :: [PP.Alignment]
+ , tHeaders :: [PP.Doc]
+ , tRows :: [[PP.Doc]]
+ }
+
+
+--------------------------------------------------------------------------------
+prettyTable
+ :: Theme -> Table -> PP.Doc
+prettyTable theme@Theme {..} Table {..} =
+ PP.indent (PP.Trimmable " ") (PP.Trimmable " ") $
+ lineIf (not isHeaderLess) (hcat2 headerHeight
+ [ themed themeTableHeader (PP.align w a (vpad headerHeight header))
+ | (w, a, header) <- zip3 columnWidths tAligns tHeaders
+ ]) <>
+ dashedHeaderSeparator theme columnWidths <$$>
+ joinRows
+ [ hcat2 rowHeight
+ [ PP.align w a (vpad rowHeight cell)
+ | (w, a, cell) <- zip3 columnWidths tAligns row
+ ]
+ | (rowHeight, row) <- zip rowHeights tRows
+ ] <$$>
+ lineIf isHeaderLess (dashedHeaderSeparator theme columnWidths) <>
+ lineIf
+ (not $ PP.null tCaption) (PP.hardline <> "Table: " <> tCaption)
+ where
+ lineIf cond line = if cond then line <> PP.hardline else mempty
+
+ joinRows
+ | all (all isSimpleCell) tRows = PP.vcat
+ | otherwise = PP.vcat . intersperse ""
+
+ isHeaderLess = all PP.null tHeaders
+
+ headerDimensions = map PP.dimensions tHeaders :: [(Int, Int)]
+ rowDimensions = map (map PP.dimensions) tRows :: [[(Int, Int)]]
+
+ columnWidths :: [Int]
+ columnWidths =
+ [ safeMax (map snd col)
+ | col <- transpose (headerDimensions : rowDimensions)
+ ]
+
+ rowHeights = map (safeMax . map fst) rowDimensions :: [Int]
+ headerHeight = safeMax (map fst headerDimensions) :: Int
+
+ vpad :: Int -> PP.Doc -> PP.Doc
+ vpad height doc =
+ let (actual, _) = PP.dimensions doc in
+ doc <> mconcat (replicate (height - actual) PP.hardline)
+
+ safeMax = foldr max 0
+
+ hcat2 :: Int -> [PP.Doc] -> PP.Doc
+ hcat2 rowHeight = PP.paste . intersperse (spaces2 rowHeight)
+
+ spaces2 :: Int -> PP.Doc
+ spaces2 rowHeight =
+ mconcat $ intersperse PP.hardline $
+ replicate rowHeight (PP.string " ")
+
+
+--------------------------------------------------------------------------------
+isSimpleCell :: PP.Doc -> Bool
+isSimpleCell = (<= 1) . fst . PP.dimensions
+
+
+--------------------------------------------------------------------------------
+dashedHeaderSeparator :: Theme -> [Int] -> PP.Doc
+dashedHeaderSeparator Theme {..} columnWidths =
+ mconcat $ intersperse (PP.string " ")
+ [ themed themeTableSeparator (PP.string (replicate w '-'))
+ | w <- columnWidths
+ ]
+
+
+--------------------------------------------------------------------------------
+-- | This does not really belong in the module.
+themed :: Maybe Theme.Style -> PP.Doc -> PP.Doc
+themed Nothing = id
+themed (Just (Theme.Style [])) = id
+themed (Just (Theme.Style codes)) = PP.ansi codes
diff --git a/lib/Patat/Presentation/Fragment.hs b/lib/Patat/Presentation/Fragment.hs
new file mode 100644
index 0000000..0908381
--- /dev/null
+++ b/lib/Patat/Presentation/Fragment.hs
@@ -0,0 +1,134 @@
+-- | For background info on the spec, see the "Incremental lists" section of the
+-- the pandoc manual.
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+module Patat.Presentation.Fragment
+ ( FragmentSettings (..)
+ , fragmentBlocks
+ , fragmentBlock
+ ) where
+
+import Data.Foldable (Foldable)
+import Data.List (foldl', intersperse)
+import Data.Maybe (fromMaybe)
+import Data.Traversable (Traversable)
+import Prelude
+import qualified Text.Pandoc as Pandoc
+
+data FragmentSettings = FragmentSettings
+ { fsIncrementalLists :: !Bool
+ } deriving (Show)
+
+-- fragmentBlocks :: [Pandoc.Block] -> [[Pandoc.Block]]
+-- fragmentBlocks = NonEmpty.toList . joinFragmentedBlocks . map fragmentBlock
+fragmentBlocks :: FragmentSettings -> [Pandoc.Block] -> [[Pandoc.Block]]
+fragmentBlocks fs blocks0 =
+ case joinFragmentedBlocks (map (fragmentBlock fs) blocks0) of
+ Unfragmented bs -> [bs]
+ Fragmented xs bs -> map (fromMaybe []) xs ++ [fromMaybe [] bs]
+
+-- | This is all the ways we can "present" a block, after splitting in
+-- fragments.
+--
+-- In the simplest (and most common case) a block can only be presented in a
+-- single way ('Unfragmented').
+--
+-- Alternatively, we might want to show different (partial) versions of the
+-- block first before showing the final complete one. These partial or complete
+-- versions can be empty, hence the 'Maybe'.
+--
+-- For example, imagine that we display the following bullet list incrementally:
+--
+-- > [1, 2, 3]
+--
+-- Then we would get something like:
+--
+-- > Fragmented [Nothing, Just [1], Just [1, 2]] (Just [1, 2, 3])
+data Fragmented a
+ = Unfragmented a
+ | Fragmented [Maybe a] (Maybe a)
+ deriving (Functor, Foldable, Show, Traversable)
+
+fragmentBlock :: FragmentSettings -> Pandoc.Block -> Fragmented Pandoc.Block
+fragmentBlock _fs block@(Pandoc.Para inlines)
+ | inlines == threeDots = Fragmented [Nothing] Nothing
+ | otherwise = Unfragmented block
+ where
+ threeDots = intersperse Pandoc.Space $ replicate 3 (Pandoc.Str ".")
+
+fragmentBlock fs (Pandoc.BulletList bs0) =
+ fragmentList fs (fsIncrementalLists fs) Pandoc.BulletList bs0
+
+fragmentBlock fs (Pandoc.OrderedList attr bs0) =
+ fragmentList fs (fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0
+
+fragmentBlock fs (Pandoc.BlockQuote [Pandoc.BulletList bs0]) =
+ fragmentList fs (not $ fsIncrementalLists fs) Pandoc.BulletList bs0
+
+fragmentBlock fs (Pandoc.BlockQuote [Pandoc.OrderedList attr bs0]) =
+ fragmentList fs (not $ fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0
+
+fragmentBlock _ block@(Pandoc.BlockQuote _) = Unfragmented block
+
+fragmentBlock _ block@(Pandoc.Header _ _ _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.Plain _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.CodeBlock _ _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.RawBlock _ _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.DefinitionList _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.Table _ _ _ _ _) = Unfragmented block
+fragmentBlock _ block@(Pandoc.Div _ _) = Unfragmented block
+fragmentBlock _ block@Pandoc.HorizontalRule = Unfragmented block
+fragmentBlock _ block@Pandoc.Null = Unfragmented block
+
+#if MIN_VERSION_pandoc(1,18,0)
+fragmentBlock _ block@(Pandoc.LineBlock _) = Unfragmented block
+#endif
+
+joinFragmentedBlocks :: [Fragmented block] -> Fragmented [block]
+joinFragmentedBlocks =
+ foldl' append (Unfragmented [])
+ where
+ append (Unfragmented xs) (Unfragmented y) =
+ Unfragmented (xs ++ [y])
+
+ append (Fragmented xs x) (Unfragmented y) =
+ Fragmented xs (appendMaybe x (Just y))
+
+ append (Unfragmented x) (Fragmented ys y) =
+ Fragmented
+ [appendMaybe (Just x) y' | y' <- ys]
+ (appendMaybe (Just x) y)
+
+ append (Fragmented xs x) (Fragmented ys y) =
+ Fragmented
+ (xs ++ [appendMaybe x y' | y' <- ys])
+ (appendMaybe x y)
+
+ appendMaybe :: Maybe [a] -> Maybe a -> Maybe [a]
+ appendMaybe Nothing Nothing = Nothing
+ appendMaybe Nothing (Just x) = Just [x]
+ appendMaybe (Just xs) Nothing = Just xs
+ appendMaybe (Just xs) (Just x) = Just (xs ++ [x])
+
+fragmentList
+ :: FragmentSettings -- ^ Global settings
+ -> Bool -- ^ Fragment THIS list?
+ -> ([[Pandoc.Block]] -> Pandoc.Block) -- ^ List constructor
+ -> [[Pandoc.Block]] -- ^ List items
+ -> Fragmented Pandoc.Block -- ^ Resulting list
+fragmentList fs fragmentThisList constructor blocks0 =
+ fmap constructor fragmented
+ where
+ -- The fragmented list per list item.
+ items :: [Fragmented [Pandoc.Block]]
+ items = map (joinFragmentedBlocks . map (fragmentBlock fs)) blocks0
+
+ fragmented :: Fragmented [[Pandoc.Block]]
+ fragmented = joinFragmentedBlocks $
+ map (if fragmentThisList then insertPause else id) items
+
+ insertPause :: Fragmented a -> Fragmented a
+ insertPause (Unfragmented x) = Fragmented [Nothing] (Just x)
+ insertPause (Fragmented xs x) = Fragmented (Nothing : xs) x
diff --git a/lib/Patat/Presentation/Interactive.hs b/lib/Patat/Presentation/Interactive.hs
new file mode 100644
index 0000000..6707e09
--- /dev/null
+++ b/lib/Patat/Presentation/Interactive.hs
@@ -0,0 +1,142 @@
+--------------------------------------------------------------------------------
+-- | Module that allows the user to interact with the presentation
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Interactive
+ ( PresentationCommand (..)
+ , readPresentationCommand
+
+ , UpdatedPresentation (..)
+ , updatePresentation
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Char (isDigit)
+import Patat.Presentation.Internal
+import Patat.Presentation.Read
+import qualified System.IO as IO
+import Text.Read (readMaybe)
+
+
+--------------------------------------------------------------------------------
+data PresentationCommand
+ = Exit
+ | Forward
+ | Backward
+ | SkipForward
+ | SkipBackward
+ | First
+ | Last
+ | Reload
+ | Seek Int
+ | UnknownCommand String
+ deriving (Eq, Show)
+
+
+--------------------------------------------------------------------------------
+readPresentationCommand :: IO.Handle -> IO PresentationCommand
+readPresentationCommand h = do
+ k <- readKeys
+ case k of
+ "q" -> return Exit
+ "\n" -> return Forward
+ "\DEL" -> return Backward
+ "h" -> return Backward
+ "j" -> return SkipForward
+ "k" -> return SkipBackward
+ "l" -> return Forward
+ -- Arrow keys
+ "\ESC[C" -> return Forward
+ "\ESC[D" -> return Backward
+ "\ESC[B" -> return SkipForward
+ "\ESC[A" -> return SkipBackward
+ -- PageUp and PageDown
+ "\ESC[6" -> return Forward
+ "\ESC[5" -> return Backward
+ "0" -> return First
+ "G" -> return Last
+ "r" -> return Reload
+ -- Number followed by enter
+ _ | Just n <- readMaybe k -> return (Seek n)
+ _ -> return (UnknownCommand k)
+ where
+ readKeys :: IO String
+ readKeys = do
+ c0 <- IO.hGetChar h
+ case c0 of
+ '\ESC' -> do
+ c1 <- IO.hGetChar h
+ case c1 of
+ '[' -> do
+ c2 <- IO.hGetChar h
+ return [c0, c1, c2]
+ _ -> return [c0, c1]
+
+ _ | isDigit c0 && c0 /= '0' -> (c0 :) <$> readDigits
+
+ _ -> return [c0]
+
+ readDigits :: IO String
+ readDigits = do
+ c <- IO.hGetChar h
+ if isDigit c then (c :) <$> readDigits else return [c]
+
+
+--------------------------------------------------------------------------------
+data UpdatedPresentation
+ = UpdatedPresentation !Presentation
+ | ExitedPresentation
+ | ErroredPresentation String
+ deriving (Show)
+
+
+--------------------------------------------------------------------------------
+updatePresentation
+ :: PresentationCommand -> Presentation -> IO UpdatedPresentation
+
+updatePresentation cmd presentation = case cmd of
+ Exit -> return ExitedPresentation
+ Forward -> return $ goToSlide $ \(s, f) -> (s, f + 1)
+ Backward -> return $ goToSlide $ \(s, f) -> (s, f - 1)
+ SkipForward -> return $ goToSlide $ \(s, _) -> (s + 10, 0)
+ SkipBackward -> return $ goToSlide $ \(s, _) -> (s - 10, 0)
+ First -> return $ goToSlide $ \_ -> (0, 0)
+ Last -> return $ goToSlide $ \_ -> (numSlides presentation, 0)
+ Seek n -> return $ goToSlide $ \_ -> (n - 1, 0)
+ Reload -> reloadPresentation
+ UnknownCommand _ -> return (UpdatedPresentation presentation)
+ where
+ numSlides :: Presentation -> Int
+ numSlides pres = length (pSlides pres)
+
+ clip :: Index -> Presentation -> Index
+ clip (slide, fragment) pres
+ | slide >= numSlides pres = (numSlides pres - 1, lastFragments - 1)
+ | slide < 0 = (0, 0)
+ | fragment >= numFragments' slide =
+ if slide + 1 >= numSlides pres
+ then (slide, lastFragments - 1)
+ else (slide + 1, 0)
+ | fragment < 0 =
+ if slide - 1 >= 0
+ then (slide - 1, numFragments' (slide - 1) - 1)
+ else (slide, 0)
+ | otherwise = (slide, fragment)
+ where
+ numFragments' s = maybe 1 numFragments (getSlide s pres)
+ lastFragments = numFragments' (numSlides pres - 1)
+
+ goToSlide :: (Index -> Index) -> UpdatedPresentation
+ goToSlide f = UpdatedPresentation $ presentation
+ { pActiveFragment = clip (f $ pActiveFragment presentation) presentation
+ }
+
+ reloadPresentation = do
+ errOrPres <- readPresentation (pFilePath presentation)
+ return $ case errOrPres of
+ Left err -> ErroredPresentation err
+ Right pres -> UpdatedPresentation $ pres
+ { pActiveFragment = clip (pActiveFragment presentation) pres
+ }
diff --git a/lib/Patat/Presentation/Internal.hs b/lib/Patat/Presentation/Internal.hs
new file mode 100644
index 0000000..db8d16b
--- /dev/null
+++ b/lib/Patat/Presentation/Internal.hs
@@ -0,0 +1,266 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Patat.Presentation.Internal
+ ( Presentation (..)
+ , PresentationSettings (..)
+ , defaultPresentationSettings
+
+ , Margins (..)
+ , marginsOf
+
+ , ExtensionList (..)
+ , defaultExtensionList
+
+ , ImageSettings (..)
+
+ , Slide (..)
+ , Fragment (..)
+ , Index
+
+ , getSlide
+ , numFragments
+
+ , ActiveFragment (..)
+ , getActiveFragment
+ ) where
+
+
+--------------------------------------------------------------------------------
+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.List (intercalate)
+import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Monoid (Monoid (..))
+import Data.Semigroup (Semigroup (..))
+import qualified Data.Text as T
+import qualified Patat.Theme as Theme
+import Prelude
+import qualified Text.Pandoc as Pandoc
+import Text.Read (readMaybe)
+
+
+--------------------------------------------------------------------------------
+data Presentation = Presentation
+ { pFilePath :: !FilePath
+ , pTitle :: ![Pandoc.Inline]
+ , pAuthor :: ![Pandoc.Inline]
+ , pSettings :: !PresentationSettings
+ , pSlides :: [Slide]
+ , pActiveFragment :: !Index
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+-- | 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 Margins)
+ , psWrap :: !(Maybe Bool)
+ , psTheme :: !(Maybe Theme.Theme)
+ , psIncrementalLists :: !(Maybe Bool)
+ , psAutoAdvanceDelay :: !(Maybe (A.FlexibleNum Int))
+ , psSlideLevel :: !(Maybe Int)
+ , psPandocExtensions :: !(Maybe ExtensionList)
+ , psImages :: !(Maybe ImageSettings)
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance Semigroup PresentationSettings where
+ l <> r = PresentationSettings
+ { psRows = psRows l `mplus` psRows r
+ , psColumns = psColumns l `mplus` psColumns r
+ , psMargins = psMargins l <> psMargins r
+ , psWrap = psWrap l `mplus` psWrap r
+ , psTheme = psTheme l <> psTheme r
+ , psIncrementalLists = psIncrementalLists l `mplus` psIncrementalLists r
+ , psAutoAdvanceDelay = psAutoAdvanceDelay l `mplus` psAutoAdvanceDelay r
+ , psSlideLevel = psSlideLevel l `mplus` psSlideLevel r
+ , psPandocExtensions = psPandocExtensions l `mplus` psPandocExtensions r
+ , psImages = psImages l `mplus` psImages r
+ }
+
+
+--------------------------------------------------------------------------------
+instance Monoid PresentationSettings where
+ mappend = (<>)
+ mempty = PresentationSettings
+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+ Nothing Nothing Nothing
+
+
+--------------------------------------------------------------------------------
+defaultPresentationSettings :: PresentationSettings
+defaultPresentationSettings = PresentationSettings
+ { psRows = Nothing
+ , psColumns = Nothing
+ , psMargins = Just defaultMargins
+ , psWrap = Nothing
+ , psTheme = Just Theme.defaultTheme
+ , psIncrementalLists = Nothing
+ , psAutoAdvanceDelay = Nothing
+ , psSlideLevel = Nothing
+ , psPandocExtensions = Nothing
+ , psImages = Nothing
+ }
+
+
+--------------------------------------------------------------------------------
+data Margins = Margins
+ { mLeft :: !(Maybe (A.FlexibleNum Int))
+ , mRight :: !(Maybe (A.FlexibleNum Int))
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance Semigroup Margins where
+ l <> r = Margins
+ { mLeft = mLeft l `mplus` mLeft r
+ , mRight = mRight l `mplus` mRight r
+ }
+
+
+--------------------------------------------------------------------------------
+instance Monoid Margins where
+ mappend = (<>)
+ mempty = Margins Nothing Nothing
+
+
+--------------------------------------------------------------------------------
+defaultMargins :: Margins
+defaultMargins = Margins
+ { mLeft = Nothing
+ , mRight = Nothing
+ }
+
+
+--------------------------------------------------------------------------------
+marginsOf :: PresentationSettings -> (Int, Int)
+marginsOf presentationSettings =
+ (marginLeft, marginRight)
+ where
+ margins = fromMaybe defaultMargins $ psMargins presentationSettings
+ marginLeft = fromMaybe 0 (A.unFlexibleNum <$> mLeft margins)
+ marginRight = fromMaybe 0 (A.unFlexibleNum <$> mRight margins)
+
+
+--------------------------------------------------------------------------------
+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 ", "
+ [ show (drop 4 (show e))
+ | e <- [minBound .. maxBound] :: [Pandoc.Extension]
+ ]
+
+
+--------------------------------------------------------------------------------
+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}
+
+
+--------------------------------------------------------------------------------
+data Slide
+ = ContentSlide [Fragment]
+ | TitleSlide Pandoc.Block
+ deriving (Show)
+
+
+--------------------------------------------------------------------------------
+newtype Fragment = Fragment {unFragment :: [Pandoc.Block]}
+ deriving (Monoid, Semigroup, Show)
+
+
+--------------------------------------------------------------------------------
+-- | Active slide, active fragment.
+type Index = (Int, Int)
+
+
+--------------------------------------------------------------------------------
+getSlide :: Int -> Presentation -> Maybe Slide
+getSlide sidx = listToMaybe . drop sidx . pSlides
+
+
+--------------------------------------------------------------------------------
+numFragments :: Slide -> Int
+numFragments (ContentSlide fragments) = length fragments
+numFragments (TitleSlide _) = 1
+
+
+--------------------------------------------------------------------------------
+data ActiveFragment = ActiveContent Fragment | ActiveTitle Pandoc.Block
+ deriving (Show)
+
+
+--------------------------------------------------------------------------------
+getActiveFragment :: Presentation -> Maybe ActiveFragment
+getActiveFragment presentation = do
+ let (sidx, fidx) = pActiveFragment presentation
+ slide <- getSlide sidx presentation
+ case slide of
+ TitleSlide block -> return (ActiveTitle block)
+ ContentSlide fragments ->
+ fmap ActiveContent . listToMaybe $ drop fidx fragments
+
+
+--------------------------------------------------------------------------------
+$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings)
+$(A.deriveFromJSON A.dropPrefixOptions ''Margins)
diff --git a/lib/Patat/Presentation/Read.hs b/lib/Patat/Presentation/Read.hs
new file mode 100644
index 0000000..581c31d
--- /dev/null
+++ b/lib/Patat/Presentation/Read.hs
@@ -0,0 +1,205 @@
+-- | Read a presentation from disk.
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Patat.Presentation.Read
+ ( readPresentation
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad.Except (ExceptT (..), runExceptT,
+ throwError)
+import Control.Monad.Trans (liftIO)
+import qualified Data.Aeson as A
+import qualified Data.HashMap.Strict as HMS
+import Data.Maybe (fromMaybe)
+import Data.Monoid (mempty, (<>))
+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.Presentation.Fragment
+import Patat.Presentation.Internal
+import Prelude
+import System.Directory (doesFileExist, getHomeDirectory)
+import System.FilePath (takeExtension, (</>))
+import qualified Text.Pandoc.Error as Pandoc
+import qualified Text.Pandoc.Extended as Pandoc
+
+
+--------------------------------------------------------------------------------
+readPresentation :: FilePath -> IO (Either String Presentation)
+readPresentation filePath = runExceptT $ do
+ -- We need to read the settings first.
+ src <- liftIO $ T.readFile filePath
+ homeSettings <- ExceptT readHomeSettings
+ metaSettings <- ExceptT $ return $ readMetaSettings src
+ let settings = metaSettings <> homeSettings <> defaultPresentationSettings
+
+ let pexts = fromMaybe defaultExtensionList (psPandocExtensions settings)
+ reader <- case readExtension pexts ext of
+ Nothing -> throwError $ "Unknown file extension: " ++ show ext
+ Just x -> return x
+ doc <- case reader src of
+ Left e -> throwError $ "Could not parse document: " ++ show e
+ Right x -> return x
+
+ ExceptT $ return $ pandocToPresentation filePath settings doc
+ where
+ ext = takeExtension filePath
+
+
+--------------------------------------------------------------------------------
+readExtension
+ :: ExtensionList -> String
+ -> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc)
+readExtension (ExtensionList extensions) fileExt = case fileExt of
+ ".md" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
+ ".lhs" -> Just $ Pandoc.runPure . Pandoc.readMarkdown lhsOpts
+ "" -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
+ ".org" -> Just $ Pandoc.runPure . Pandoc.readOrg readerOpts
+ _ -> Nothing
+
+ where
+ readerOpts = Pandoc.def
+ { Pandoc.readerExtensions =
+ extensions <> absolutelyRequiredExtensions
+ }
+
+ lhsOpts = readerOpts
+ { Pandoc.readerExtensions =
+ Pandoc.readerExtensions readerOpts <>
+ Pandoc.extensionsFromList [Pandoc.Ext_literate_haskell]
+ }
+
+ absolutelyRequiredExtensions =
+ Pandoc.extensionsFromList [Pandoc.Ext_yaml_metadata_block]
+
+
+--------------------------------------------------------------------------------
+pandocToPresentation
+ :: FilePath -> PresentationSettings -> Pandoc.Pandoc
+ -> Either String Presentation
+pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do
+ let !pTitle = Pandoc.docTitle meta
+ !pSlides = pandocToSlides pSettings pandoc
+ !pActiveFragment = (0, 0)
+ !pAuthor = concat (Pandoc.docAuthors meta)
+ return Presentation {..}
+
+
+--------------------------------------------------------------------------------
+-- | This re-parses the pandoc metadata block using the YAML library. This
+-- avoids the problems caused by pandoc involving rendering Markdown. This
+-- should only be used for settings though, not things like title / authors
+-- since those /can/ contain markdown.
+parseMetadataBlock :: T.Text -> Maybe A.Value
+parseMetadataBlock src = do
+ block <- T.encodeUtf8 <$> mbBlock
+ either (const Nothing) Just (Yaml.decodeEither' block)
+ where
+ mbBlock :: Maybe T.Text
+ mbBlock = case T.lines src of
+ ("---" : ls) -> case break (`elem` ["---", "..."]) ls of
+ (_, []) -> Nothing
+ (block, (_ : _)) -> Just (T.unlines block)
+ _ -> Nothing
+
+
+--------------------------------------------------------------------------------
+-- | Read settings from the metadata block in the Pandoc document.
+readMetaSettings :: T.Text -> Either String PresentationSettings
+readMetaSettings src = fromMaybe (Right mempty) $ do
+ A.Object obj <- parseMetadataBlock src
+ val <- HMS.lookup "patat" obj
+ return $! resultToEither $! A.fromJSON val
+ where
+ resultToEither :: A.Result a -> Either String a
+ resultToEither (A.Success x) = Right x
+ resultToEither (A.Error e) = Left $!
+ "Error parsing patat settings from metadata: " ++ e
+
+
+--------------------------------------------------------------------------------
+-- | Read settings from "$HOME/.patat.yaml".
+readHomeSettings :: IO (Either String PresentationSettings)
+readHomeSettings = do
+ home <- getHomeDirectory
+ let path = home </> ".patat.yaml"
+ exists <- doesFileExist path
+ if not exists
+ then return (Right mempty)
+ else do
+ errOrPs <- Yaml.decodeFileEither path
+ return $! case errOrPs of
+ Left err -> Left (show err)
+ Right ps -> Right ps
+
+
+--------------------------------------------------------------------------------
+pandocToSlides :: PresentationSettings -> Pandoc.Pandoc -> [Slide]
+pandocToSlides settings pandoc =
+ let slideLevel = fromMaybe (detectSlideLevel pandoc) (psSlideLevel settings)
+ unfragmented = splitSlides slideLevel pandoc
+ fragmented =
+ [ case slide of
+ TitleSlide _ -> slide
+ ContentSlide fragments0 ->
+ let blocks = concatMap unFragment fragments0
+ blockss = fragmentBlocks fragmentSettings blocks in
+ ContentSlide (map Fragment blockss)
+ | slide <- unfragmented
+ ] in
+ fragmented
+ where
+ fragmentSettings = FragmentSettings
+ { fsIncrementalLists = fromMaybe False (psIncrementalLists settings)
+ }
+
+
+--------------------------------------------------------------------------------
+-- | Find level of header that starts slides. This is defined as the least
+-- header that occurs before a non-header in the blocks.
+detectSlideLevel :: Pandoc.Pandoc -> Int
+detectSlideLevel (Pandoc.Pandoc _meta blocks0) =
+ go 6 blocks0
+ where
+ go level (Pandoc.Header n _ _ : x : xs)
+ | n < level && nonHeader x = go n xs
+ | otherwise = go level (x:xs)
+ go level (_ : xs) = go level xs
+ go level [] = level
+
+ nonHeader (Pandoc.Header _ _ _) = False
+ nonHeader _ = True
+
+
+--------------------------------------------------------------------------------
+-- | Split a pandoc document into slides. If the document contains horizonal
+-- rules, we use those as slide delimiters. If there are no horizontal rules,
+-- we split using headers, determined by the slide level (see
+-- 'detectSlideLevel').
+splitSlides :: Int -> Pandoc.Pandoc -> [Slide]
+splitSlides slideLevel (Pandoc.Pandoc _meta blocks0)
+ | any (== Pandoc.HorizontalRule) blocks0 = splitAtRules blocks0
+ | otherwise = splitAtHeaders [] blocks0
+ where
+ mkContentSlide :: [Pandoc.Block] -> [Slide]
+ mkContentSlide [] = [] -- Never create empty slides
+ mkContentSlide bs = [ContentSlide [Fragment bs]]
+
+ splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of
+ (xs, []) -> mkContentSlide xs
+ (xs, (_rule : ys)) -> mkContentSlide xs ++ splitAtRules ys
+
+ splitAtHeaders acc [] =
+ mkContentSlide (reverse acc)
+ splitAtHeaders acc (b@(Pandoc.Header i _ _) : bs)
+ | i > slideLevel = splitAtHeaders (b : acc) bs
+ | i == slideLevel =
+ mkContentSlide (reverse acc) ++ splitAtHeaders [b] bs
+ | otherwise =
+ mkContentSlide (reverse acc) ++ [TitleSlide b] ++ splitAtHeaders [] bs
+ splitAtHeaders acc (b : bs) =
+ splitAtHeaders (b : acc) bs