patat-0.12.0.0: lib/Patat/Presentation/Display.hs
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Patat.Presentation.Display
( Display (..)
, displayPresentation
, displayPresentationError
, dumpPresentation
) where
--------------------------------------------------------------------------------
import Control.Monad (guard)
import qualified Data.Aeson.Extended as A
import Data.Char.WCWidth.Extended (wcstrwidth)
import Data.Data.Extended (grecQ)
import qualified Data.List as L
import Data.Maybe (fromMaybe, maybeToList)
import qualified Data.Sequence.Extended as Seq
import qualified Data.Text as T
import qualified Patat.Presentation.Comments as Comments
import Patat.Presentation.Display.CodeBlock
import Patat.Presentation.Display.Internal
import Patat.Presentation.Display.Table
import Patat.Presentation.Internal
import Patat.Presentation.Settings
import Patat.PrettyPrint ((<$$>), (<+>))
import qualified Patat.PrettyPrint as PP
import Patat.Size
import Patat.Theme (Theme (..))
import qualified Patat.Theme as Theme
import Prelude
import qualified Text.Pandoc.Extended as Pandoc
import qualified Text.Pandoc.Writers.Shared as Pandoc
--------------------------------------------------------------------------------
data Display = DisplayDoc PP.Doc | DisplayImage FilePath deriving (Show)
--------------------------------------------------------------------------------
-- | Display something within the presentation borders that draw the title and
-- the active slide number and so on.
displayWithBorders
:: Size -> Presentation -> (DisplaySettings -> PP.Doc) -> PP.Doc
displayWithBorders (Size rows columns) pres@Presentation {..} f =
(if null title
then mempty
else
let titleRemainder = columns - titleWidth - titleOffset
wrappedTitle = PP.spaces titleOffset <> PP.string title <> PP.spaces titleRemainder in
borders wrappedTitle <> PP.hardline) <>
f 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
{ 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
}
-- Compute title.
breadcrumbs = fromMaybe [] $ Seq.safeIndex pBreadcrumbs sidx
plainTitle = PP.toString $ prettyInlines ds pTitle
breadTitle = mappend plainTitle $ mconcat
[ s
| b <- map (prettyInlines ds . snd) breadcrumbs
, s <- [" > ", PP.toString b]
]
title
| not . fromMaybe True $ psBreadcrumbs settings = plainTitle
| wcstrwidth breadTitle > columns = plainTitle
| otherwise = breadTitle
-- Dimensions of title.
titleWidth = wcstrwidth title
titleOffset = (columns - titleWidth) `div` 2
borders = themed ds themeBorders
-- Room left for content
canvasSize = Size (rows - 3) columns
-- Compute footer.
active
| fromMaybe True $ psSlideNumber settings = show (sidx + 1) ++ " / " ++ show (length pSlides)
| otherwise = ""
activeWidth = wcstrwidth active
author = PP.toString (prettyInlines ds pAuthor)
authorWidth = wcstrwidth author
middleSpaces = PP.spaces $ columns - activeWidth - authorWidth - 2
--------------------------------------------------------------------------------
displayPresentation :: Size -> Presentation -> Display
displayPresentation size pres@Presentation {..} =
case activeFragment pres of
Nothing -> DisplayDoc $ displayWithBorders size pres mempty
Just (ActiveContent fragment)
| Just _ <- psImages pSettings
, Just image <- onlyImage fragment ->
DisplayImage $ T.unpack image
Just (ActiveContent fragment) -> DisplayDoc $
displayWithBorders size pres $ \theme ->
prettyFragment theme fragment
Just (ActiveTitle block) -> DisplayDoc $
displayWithBorders size pres $ \ds ->
let auto = Margins {mTop = Auto, mRight = Auto, mLeft = Auto} in
prettyFragment ds {dsMargins = auto} $ Fragment [block]
where
-- Check if the fragment consists of "just a single image". Discard
-- headers.
onlyImage (Fragment (Pandoc.Header{} : bs)) = onlyImage (Fragment bs)
onlyImage (Fragment bs) = case bs of
[Pandoc.Figure _ _ bs'] -> onlyImage (Fragment bs')
[Pandoc.Para [Pandoc.Image _ _ (target, _)]] -> Just target
_ -> 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 :: Size -> Presentation -> String -> PP.Doc
displayPresentationError size pres err = displayWithBorders size pres $ \ds ->
themed ds themeStrong "Error occurred in the presentation:" <$$>
"" <$$>
(PP.string err)
--------------------------------------------------------------------------------
dumpPresentation :: Presentation -> IO ()
dumpPresentation pres@Presentation {..} =
PP.putDoc $ PP.removeControls $
PP.vcat $ L.intercalate ["{slide}"] $
map dumpSlide [0 .. length pSlides - 1]
where
dumpSlide :: Int -> [PP.Doc]
dumpSlide i = do
slide <- maybeToList $ getSlide i pres
dumpComment slide <> L.intercalate ["{fragment}"]
[ dumpFragment (i, j)
| j <- [0 .. numFragments slide - 1]
]
dumpComment :: Slide -> [PP.Doc]
dumpComment slide = do
guard (Comments.cSpeakerNotes comment /= mempty)
pure $ PP.text $ "{speakerNotes: " <>
Comments.speakerNotesToText (Comments.cSpeakerNotes comment) <> "}"
where
comment = slideComment slide
dumpFragment :: Index -> [PP.Doc]
dumpFragment idx =
case displayPresentation (getSize idx) pres {pActiveFragment = idx} of
DisplayDoc doc -> [doc]
DisplayImage filepath -> [PP.string $ "{image: " ++ filepath ++ "}"]
getSize :: Index -> Size
getSize idx =
let settings = activeSettings pres {pActiveFragment = idx}
sRows = fromMaybe 24 $ A.unFlexibleNum <$> psRows settings
sCols = fromMaybe 72 $ A.unFlexibleNum <$> psColumns settings in
Size {..}
--------------------------------------------------------------------------------
prettyFragment :: DisplaySettings -> Fragment -> PP.Doc
prettyFragment ds (Fragment blocks) = vertical $
PP.vcat (map (horizontal . prettyBlock ds) blocks) <>
case prettyReferences ds blocks of
[] -> mempty
refs -> PP.hardline <> PP.vcat (map horizontal refs)
where
Size rows columns = dsSize ds
Margins {..} = dsMargins ds
vertical doc0 =
mconcat (replicate top PP.hardline) <> doc0
where
top = case mTop of
Auto -> let (r, _) = PP.dimensions doc0 in (rows - r) `div` 2
NotAuto x -> x
horizontal = horizontalIndent . horizontalWrap
horizontalIndent doc0 = PP.indent indentation indentation doc1
where
doc1 = case (mLeft, mRight) of
(Auto, Auto) -> PP.deindent doc0
_ -> doc0
(_, dcols) = PP.dimensions doc1
left = case mLeft of
NotAuto x -> x
Auto -> case mRight of
NotAuto _ -> 0
Auto -> (columns - dcols) `div` 2
indentation = PP.Indentation left mempty
horizontalWrap doc0 = case dsWrap ds of
NoWrap -> doc0
AutoWrap -> PP.wrapAt (Just $ columns - right - left) doc0
WrapAt col -> PP.wrapAt (Just col) doc0
where
right = case mRight of
Auto -> 0
NotAuto x -> x
left = case mLeft of
Auto -> 0
NotAuto x -> x
--------------------------------------------------------------------------------
prettyBlock :: DisplaySettings -> Pandoc.Block -> PP.Doc
prettyBlock ds (Pandoc.Plain inlines) = prettyInlines ds inlines
prettyBlock ds (Pandoc.Para inlines) =
prettyInlines ds inlines <> PP.hardline
prettyBlock ds (Pandoc.Header i _ inlines) =
themed ds themeHeader (PP.string (replicate i '#') <+> prettyInlines ds inlines) <>
PP.hardline
prettyBlock ds (Pandoc.CodeBlock (_, classes, _) txt) =
prettyCodeBlock ds classes txt
prettyBlock ds (Pandoc.BulletList bss) = PP.vcat
[ PP.indent
(PP.Indentation 2 $ themed ds themeBulletList prefix)
(PP.Indentation 4 mempty)
(prettyBlocks ds' bs)
| bs <- bss
] <> PP.hardline
where
prefix = PP.string [marker] <> " "
marker = case T.unpack <$> themeBulletListMarkers theme of
Just (x : _) -> x
_ -> '-'
-- Cycle the markers.
theme = dsTheme ds
theme' = theme
{ themeBulletListMarkers =
(\ls -> T.drop 1 ls <> T.take 1 ls) <$> themeBulletListMarkers theme
}
ds' = ds {dsTheme = theme'}
prettyBlock ds (Pandoc.OrderedList _ bss) = PP.vcat
[ PP.indent
(PP.Indentation 0 $ themed ds themeOrderedList $ PP.string prefix)
(PP.Indentation 4 mempty)
(prettyBlocks ds 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 _ds (Pandoc.RawBlock _ t) = PP.text t <> PP.hardline
prettyBlock _ds Pandoc.HorizontalRule = "---"
prettyBlock ds (Pandoc.BlockQuote bs) =
let quote = PP.Indentation 0 (themed ds themeBlockQuote "> ") in
PP.indent quote quote (themed ds themeBlockQuote $ prettyBlocks ds bs)
prettyBlock ds (Pandoc.DefinitionList terms) =
PP.vcat $ map prettyDefinition terms
where
prettyDefinition (term, definitions) =
themed ds themeDefinitionTerm (prettyInlines ds term) <$$>
PP.hardline <> PP.vcat
[ PP.indent
(PP.Indentation 0 (themed ds themeDefinitionList ": "))
(PP.Indentation 4 mempty) $
prettyBlocks ds (Pandoc.plainToPara definition)
| definition <- definitions
]
prettyBlock ds (Pandoc.Table _ caption specs thead tbodies tfoot) =
PP.wrapAt Nothing $
prettyTable ds Table
{ tCaption = prettyInlines ds caption'
, tAligns = map align aligns
, tHeaders = map (prettyBlocks ds) headers
, tRows = map (map (prettyBlocks ds)) rows
}
where
(caption', aligns, _, headers, rows) = Pandoc.toLegacyTable
caption specs thead tbodies tfoot
align Pandoc.AlignLeft = PP.AlignLeft
align Pandoc.AlignCenter = PP.AlignCenter
align Pandoc.AlignDefault = PP.AlignLeft
align Pandoc.AlignRight = PP.AlignRight
prettyBlock ds (Pandoc.Div _attrs blocks) = prettyBlocks ds blocks
prettyBlock ds (Pandoc.LineBlock inliness) =
let ind = PP.Indentation 0 (themed ds themeLineBlock "| ") in
PP.wrapAt Nothing $
PP.indent ind ind $
PP.vcat $
map (prettyInlines ds) inliness
prettyBlock ds (Pandoc.Figure _attr _caption blocks) =
prettyBlocks ds blocks
--------------------------------------------------------------------------------
prettyBlocks :: DisplaySettings -> [Pandoc.Block] -> PP.Doc
prettyBlocks ds = PP.vcat . map (prettyBlock ds)
--------------------------------------------------------------------------------
prettyInline :: DisplaySettings -> Pandoc.Inline -> PP.Doc
prettyInline _ds Pandoc.Space = PP.space
prettyInline _ds (Pandoc.Str str) = PP.text str
prettyInline ds (Pandoc.Emph inlines) =
themed ds themeEmph $
prettyInlines ds inlines
prettyInline ds (Pandoc.Strong inlines) =
themed ds themeStrong $
prettyInlines ds inlines
prettyInline ds (Pandoc.Underline inlines) =
themed ds themeUnderline $
prettyInlines ds inlines
prettyInline ds (Pandoc.Code _ txt) =
themed ds themeCode $
PP.text (" " <> txt <> " ")
prettyInline ds link@(Pandoc.Link _attrs text (target, _title))
| isReferenceLink link =
"[" <> themed ds themeLinkText (prettyInlines ds text) <> "]"
| otherwise =
"<" <> themed ds themeLinkTarget (PP.text target) <> ">"
prettyInline _ds Pandoc.SoftBreak = PP.softline
prettyInline _ds Pandoc.LineBreak = PP.hardline
prettyInline ds (Pandoc.Strikeout t) =
"~~" <> themed ds themeStrikeout (prettyInlines ds t) <> "~~"
prettyInline ds (Pandoc.Quoted Pandoc.SingleQuote t) =
"'" <> themed ds themeQuoted (prettyInlines ds t) <> "'"
prettyInline ds (Pandoc.Quoted Pandoc.DoubleQuote t) =
"'" <> themed ds themeQuoted (prettyInlines ds t) <> "'"
prettyInline ds (Pandoc.Math _ t) =
themed ds themeMath (PP.text t)
prettyInline ds (Pandoc.Image _attrs text (target, _title)) =
"![" <> themed ds themeImageText (prettyInlines ds text) <> "](" <>
themed ds themeImageTarget (PP.text target) <> ")"
prettyInline _ (Pandoc.RawInline _ t) = PP.text t
-- These elements aren't really supported.
prettyInline ds (Pandoc.Cite _ t) = prettyInlines ds t
prettyInline ds (Pandoc.Span _ t) = prettyInlines ds t
prettyInline ds (Pandoc.Note t) = prettyBlocks ds t
prettyInline ds (Pandoc.Superscript t) = prettyInlines ds t
prettyInline ds (Pandoc.Subscript t) = prettyInlines ds t
prettyInline ds (Pandoc.SmallCaps t) = prettyInlines ds t
-- prettyInline unsupported = PP.ondullred $ PP.string $ show unsupported
--------------------------------------------------------------------------------
prettyInlines :: DisplaySettings -> [Pandoc.Inline] -> PP.Doc
prettyInlines ds = mconcat . map (prettyInline ds)
--------------------------------------------------------------------------------
prettyReferences :: DisplaySettings -> [Pandoc.Block] -> [PP.Doc]
prettyReferences ds =
map prettyReference . getReferences
where
getReferences :: [Pandoc.Block] -> [Pandoc.Inline]
getReferences = filter isReferenceLink . grecQ
prettyReference :: Pandoc.Inline -> PP.Doc
prettyReference (Pandoc.Link _attrs text (target, title)) =
"[" <>
themed ds themeLinkText
(prettyInlines ds $ Pandoc.newlineToSpace text) <>
"](" <>
themed ds themeLinkTarget (PP.text target) <>
(if T.null title
then mempty
else PP.space <> "\"" <> PP.text title <> "\"")
<> ")"
prettyReference _ = mempty
--------------------------------------------------------------------------------
isReferenceLink :: Pandoc.Inline -> Bool
isReferenceLink (Pandoc.Link _attrs text (target, _)) =
[Pandoc.Str target] /= text
isReferenceLink _ = False