diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Changelog +- 0.8.7.0 (2021-03-12) + * Fix alignment and display of CJK characters in presentation title, author + and tables + * Add support for showing images in Kitty terminal + * Search in `$PATH` for `w3mimgdisplay` + * Bump `pandoc` dependency to 2.11 + * Refactor `Patat.Presentation.Display` module to make it pure + - 0.8.6.1 (2020-09-18) * Fix issue with laziness for evaluted code blocks, they should only be evaluated when we actually want to show them diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -453,7 +453,7 @@ `blockQuote`, `borders`, `bulletList`, `codeBlock`, `code`, `definitionList`, `definitionTerm`, `emph`, `header`, `imageTarget`, `imageText`, `linkTarget`, `linkText`, `math`, `orderedList`, `quoted`, `strikeout`, `strong`, -`tableHeader`, `tableSeparator` +`tableHeader`, `tableSeparator`, `underline` The accepted styles are: @@ -565,6 +565,9 @@ - `backend: iterm2`: uses [iTerm2](https://iterm2.com/)'s special escape sequence to render the image. This even works with animated GIFs! + +- `backend: kitty`: uses + [Kitty's icat command](https://sw.kovidgoyal.net/kitty/kittens/icat.html). - `backend: w3m`: uses the `w3mimgdisplay` executable to draw directly onto the window. This has been tested in `urxvt` and `xterm`, but is known to diff --git a/lib/Data/Char/WCWidth/Extended.hs b/lib/Data/Char/WCWidth/Extended.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Char/WCWidth/Extended.hs @@ -0,0 +1,9 @@ +module Data.Char.WCWidth.Extended + ( module Data.Char.WCWidth + , wcstrwidth + ) where + +import Data.Char.WCWidth + +wcstrwidth :: String -> Int +wcstrwidth = sum . map wcwidth diff --git a/lib/Patat/Images.hs b/lib/Patat/Images.hs --- a/lib/Patat/Images.hs +++ b/lib/Patat/Images.hs @@ -15,6 +15,7 @@ import Patat.Cleanup import Patat.Images.Internal import qualified Patat.Images.ITerm2 as ITerm2 +import qualified Patat.Images.Kitty as Kitty import qualified Patat.Images.W3m as W3m import Patat.Presentation.Internal @@ -52,6 +53,7 @@ backends :: [(T.Text, Backend)] backends = [ ("iterm2", ITerm2.backend) + , ("kitty", Kitty.backend) , ("w3m", W3m.backend) ] diff --git a/lib/Patat/Images/Kitty.hs b/lib/Patat/Images/Kitty.hs new file mode 100644 --- /dev/null +++ b/lib/Patat/Images/Kitty.hs @@ -0,0 +1,46 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE TemplateHaskell #-} +module Patat.Images.Kitty + ( backend + ) where + + +-------------------------------------------------------------------------------- +import Control.Exception (throwIO) +import Control.Monad (unless, void, when) +import qualified Data.Aeson as A +import qualified Data.List as L +import Patat.Cleanup (Cleanup) +import qualified Patat.Images.Internal as Internal +import Data.Functor (($>)) +import System.Environment (lookupEnv) +import System.Process (readProcess) + + +-------------------------------------------------------------------------------- +backend :: Internal.Backend +backend = Internal.Backend new + + +-------------------------------------------------------------------------------- +data Config = Config deriving (Eq) +instance A.FromJSON Config where parseJSON _ = return Config + + +-------------------------------------------------------------------------------- +new :: Internal.Config Config -> IO Internal.Handle +new config = do + when (config == Internal.Auto) $ do + term <- lookupEnv "TERM" + unless (maybe False ("kitty" `L.isInfixOf`) term) $ throwIO $ + Internal.BackendNotSupported "TERM does not indicate kitty" + + return Internal.Handle {Internal.hDrawImage = drawImage} + + +-------------------------------------------------------------------------------- +drawImage :: FilePath -> IO Cleanup +drawImage path = icat ["--align=center", path] $> icat ["--clear"] + where + icat args = void $ readProcess + "kitty" ("+kitten" : "icat" : "--transfer-mode=stream" : args) "" diff --git a/lib/Patat/Images/W3m.hs b/lib/Patat/Images/W3m.hs --- a/lib/Patat/Images/W3m.hs +++ b/lib/Patat/Images/W3m.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} module Patat.Images.W3m ( backend @@ -6,7 +7,7 @@ -------------------------------------------------------------------------------- -import Control.Exception (throwIO) +import Control.Exception (IOException, throwIO, try) import Control.Monad (unless, void) import qualified Data.Aeson.TH.Extended as A import Data.List (intercalate) @@ -44,14 +45,21 @@ -------------------------------------------------------------------------------- findW3m :: Maybe FilePath -> IO W3m -findW3m mbPath - | Just path <- mbPath = do +findW3m = \case + -- Use the path specified by the user. + Just path -> do exe <- isExecutable path if exe - then return (W3m path) + then pure $ W3m path else throwIO $ Internal.BackendNotSupported $ path ++ " is not executable" - | otherwise = W3m <$> find paths + + Nothing -> do + let path = W3m "w3mimgdisplay" + errOrSize <- try $ getTerminalSize path + case errOrSize :: Either IOException (Int, Int) of + Right _ -> pure path -- Found it. + Left _ -> W3m <$> find paths -- Look in some hardcoded paths. where find [] = throwIO $ Internal.BackendNotSupported "w3mimgdisplay executable not found" diff --git a/lib/Patat/Main.hs b/lib/Patat/Main.hs --- a/lib/Patat/Main.hs +++ b/lib/Patat/Main.hs @@ -14,6 +14,7 @@ import Control.Exception (bracket) import Control.Monad (forever, unless, when) import qualified Data.Aeson.Extended as A +import Data.Functor (($>)) import qualified Data.Text as T import Data.Time (UTCTime) import Data.Version (showVersion) @@ -21,6 +22,7 @@ import Patat.AutoAdvance import qualified Patat.Images as Images import Patat.Presentation +import qualified Patat.PrettyPrint as PP import qualified Paths_patat import Prelude import qualified System.Console.ANSI as Ansi @@ -29,7 +31,7 @@ import System.Exit (exitFailure, exitSuccess) import qualified System.IO as IO import qualified Text.Pandoc as Pandoc -import qualified Text.PrettyPrint.ANSI.Leijen as PP +import qualified Text.PrettyPrint.ANSI.Leijen as PPL -------------------------------------------------------------------------------- @@ -75,7 +77,7 @@ OA.header ("patat v" <> showVersion Paths_patat.version) <> OA.progDescDoc (Just desc) where - desc = PP.vcat + desc = PPL.vcat [ "Terminal-based presentations using Pandoc" , "" , "Controls:" @@ -157,9 +159,25 @@ let loop :: Presentation -> Maybe String -> IO () loop pres mbError = do - cleanup <- case mbError of - Nothing -> displayPresentation images pres - Just err -> displayPresentationError pres err + size <- getDisplaySize pres + let display = case mbError of + Nothing -> displayPresentation size pres + Just err -> DisplayDoc $ + displayPresentationError size pres err + + Ansi.clearScreen + Ansi.setCursorPosition 0 0 + cleanup <- case display of + DisplayDoc doc -> PP.putDoc doc $> mempty + DisplayImage path -> case images of + Nothing -> do + PP.putDoc $ displayPresentationError + size pres "image backend not initialized" + pure mempty + Just img -> do + putStrLn "" + IO.hFlush IO.stdout + Images.drawImage img path c <- Chan.readChan commandChan update <- updatePresentation c pres diff --git a/lib/Patat/Presentation.hs b/lib/Patat/Presentation.hs --- a/lib/Patat/Presentation.hs +++ b/lib/Patat/Presentation.hs @@ -4,6 +4,11 @@ , Presentation (..) , readPresentation + + , Size + , getDisplaySize + + , Display (..) , displayPresentation , displayPresentationError , dumpPresentation diff --git a/lib/Patat/Presentation/Display.hs b/lib/Patat/Presentation/Display.hs --- a/lib/Patat/Presentation/Display.hs +++ b/lib/Patat/Presentation/Display.hs @@ -1,134 +1,131 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Patat.Presentation.Display - ( displayPresentation + ( Size + , getDisplaySize + + , Display (..) + , displayPresentation , displayPresentationError , dumpPresentation ) where -------------------------------------------------------------------------------- -import Control.Monad (mplus, unless) +import Control.Monad (mplus) 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, listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe, + maybeToList) 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 qualified Patat.Presentation.Instruction as Instruction 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 +import qualified Text.Pandoc.Writers.Shared as Pandoc -------------------------------------------------------------------------------- -data CanvasSize = CanvasSize {csRows :: Int, csCols :: Int} deriving (Show) +data Size = Size {sRows :: Int, sCols :: 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 +getDisplaySize :: Presentation -> IO Size +getDisplaySize Presentation {..} = do mbWindow <- Terminal.size - let columns = fromMaybe 72 $ - (A.unFlexibleNum <$> psColumns pSettings) `mplus` - (Terminal.width <$> mbWindow) - rows = fromMaybe 24 $ + let sRows = fromMaybe 24 $ (A.unFlexibleNum <$> psRows pSettings) `mplus` (Terminal.height <$> mbWindow) + sCols = fromMaybe 72 $ + (A.unFlexibleNum <$> psColumns pSettings) `mplus` + (Terminal.width <$> mbWindow) + pure $ Size {..} - let (sidx, _) = pActiveFragment - settings = pSettings {psColumns = Just $ A.FlexibleNum columns} - theme = fromMaybe Theme.defaultTheme (psTheme settings) - let breadcrumbs = fromMaybe [] . listToMaybe $ drop sidx pBreadcrumbs - plainTitle = PP.toString $ prettyInlines theme pTitle - breadTitle = mappend plainTitle $ mconcat - [ s - | b <- map (prettyInlines theme . snd) breadcrumbs - , s <- [" > ", PP.toString b] - ] - title - | not . fromMaybe True $ psBreadcrumbs settings = plainTitle - | length breadTitle > columns = plainTitle - | otherwise = breadTitle +-------------------------------------------------------------------------------- +data Display = DisplayDoc PP.Doc | DisplayImage FilePath deriving (Show) - 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 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 +-------------------------------------------------------------------------------- +-- | Display something within the presentation borders that draw the title and +-- the active slide number and so on. +displayWithBorders + :: Size -> Presentation -> (Size -> Theme -> PP.Doc) -> PP.Doc +displayWithBorders (Size rows columns) 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 <> PP.hardline) <> + formatWith settings (f canvasSize theme) <> 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 = pSettings {psColumns = Just $ A.FlexibleNum columns} + theme = fromMaybe Theme.defaultTheme (psTheme settings) - Ansi.setCursorPosition (rows - 1) 0 - PP.putDoc $ borders $ PP.space <> PP.string author <> middleSpaces <> PP.string active <> PP.space - IO.hFlush IO.stdout + -- Compute title. + breadcrumbs = fromMaybe [] . listToMaybe $ drop sidx pBreadcrumbs + plainTitle = PP.toString $ prettyInlines theme pTitle + breadTitle = mappend plainTitle $ mconcat + [ s + | b <- map (prettyInlines theme . snd) breadcrumbs + , s <- [" > ", PP.toString b] + ] + title + | not . fromMaybe True $ psBreadcrumbs settings = plainTitle + | wcstrwidth breadTitle > columns = plainTitle + | otherwise = breadTitle - return mempty + -- Dimensions of title. + titleWidth = wcstrwidth title + titleOffset = (columns - titleWidth) `div` 2 + borders = themed (themeBorders theme) + -- Room left for content + canvasSize = Size (rows - 2) columns --------------------------------------------------------------------------------- -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 + -- Compute footer. + active = show (sidx + 1) ++ " / " ++ show (length pSlides) + activeWidth = wcstrwidth active + author = PP.toString (prettyInlines theme pAuthor) + authorWidth = wcstrwidth author + middleSpaces = PP.spaces $ columns - activeWidth - authorWidth - 2 -------------------------------------------------------------------------------- -displayPresentation :: Maybe Images.Handle -> Presentation -> IO Cleanup -displayPresentation mbImages pres@Presentation {..} = +displayPresentation :: Size -> Presentation -> Display +displayPresentation size pres@Presentation {..} = case getActiveFragment pres of - Nothing -> displayWithBorders pres mempty + Nothing -> DisplayDoc $ displayWithBorders size pres mempty Just (ActiveContent fragment) - | Just images <- mbImages + | Just _ <- psImages pSettings , Just image <- onlyImage fragment -> - displayImage images $ T.unpack image - Just (ActiveContent fragment) -> - displayWithBorders pres $ \_canvasSize theme -> - prettyFragment theme fragment - Just (ActiveTitle block) -> - displayWithBorders pres $ \canvasSize theme -> + DisplayImage $ T.unpack image + Just (ActiveContent fragment) -> DisplayDoc $ + displayWithBorders size pres $ \_canvasSize theme -> + prettyFragment theme fragment + Just (ActiveTitle block) -> DisplayDoc $ + displayWithBorders size 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) + offsetRow = (sRows canvasSize `div` 2) - (prows `div` 2) + offsetCol = ((sCols 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 @@ -150,28 +147,28 @@ -------------------------------------------------------------------------------- -- | 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) +displayPresentationError :: Size -> Presentation -> String -> PP.Doc +displayPresentationError size pres err = + displayWithBorders size 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 l inlines -> "~~~title" <$$> - prettyBlock theme (Pandoc.Header l Pandoc.nullAttr inlines) - ContentSlide instrs -> PP.vcat $ L.intersperse "~~~frag" $ do - n <- [0 .. Instruction.numFragments instrs - 1] - return $ prettyFragment theme $ - Instruction.renderFragment n instrs +dumpPresentation pres@Presentation {..} = + let sRows = fromMaybe 24 $ A.unFlexibleNum <$> psRows pSettings + sCols = fromMaybe 72 $ A.unFlexibleNum <$> psColumns pSettings + size = Size {..} in + PP.putDoc $ PP.removeControls $ formatWith pSettings $ + PP.vcat $ L.intersperse "----------" $ do + i <- [0 .. length pSlides - 1] + slide <- maybeToList $ getSlide i pres + j <- [0 .. numFragments slide - 1] + case displayPresentation size pres {pActiveFragment = (i, j)} of + DisplayDoc doc -> [doc] + DisplayImage _ -> [] -------------------------------------------------------------------------------- @@ -264,15 +261,18 @@ | definition <- definitions ] -prettyBlock theme (Pandoc.Table caption aligns _ headers rows) = +prettyBlock theme (Pandoc.Table _ caption specs thead tbodies tfoot) = PP.wrapAt Nothing $ prettyTable theme Table - { tCaption = prettyInlines theme caption + { tCaption = prettyInlines theme caption' , tAligns = map align aligns , tHeaders = map (prettyBlocks theme) headers , tRows = map (map (prettyBlocks theme)) 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 @@ -311,6 +311,10 @@ prettyInline theme@Theme {..} (Pandoc.Strong inlines) = themed themeStrong $ + prettyInlines theme inlines + +prettyInline theme@Theme {..} (Pandoc.Underline inlines) = + themed themeUnderline $ prettyInlines theme inlines prettyInline Theme {..} (Pandoc.Code _ txt) = diff --git a/lib/Patat/Presentation/Fragment.hs b/lib/Patat/Presentation/Fragment.hs --- a/lib/Patat/Presentation/Fragment.hs +++ b/lib/Patat/Presentation/Fragment.hs @@ -56,18 +56,18 @@ fragmentBlock fs (Pandoc.BlockQuote [Pandoc.OrderedList attr bs0]) = fragmentList fs (not $ fsIncrementalLists fs) (Pandoc.OrderedList attr) bs0 -fragmentBlock _ block@(Pandoc.BlockQuote _) = [Append [block]] +fragmentBlock _ block@(Pandoc.BlockQuote {}) = [Append [block]] -fragmentBlock _ block@(Pandoc.Header _ _ _) = [Append [block]] -fragmentBlock _ block@(Pandoc.Plain _) = [Append [block]] -fragmentBlock _ block@(Pandoc.CodeBlock _ _) = [Append [block]] -fragmentBlock _ block@(Pandoc.RawBlock _ _) = [Append [block]] -fragmentBlock _ block@(Pandoc.DefinitionList _) = [Append [block]] -fragmentBlock _ block@(Pandoc.Table _ _ _ _ _) = [Append [block]] -fragmentBlock _ block@(Pandoc.Div _ _) = [Append [block]] -fragmentBlock _ block@Pandoc.HorizontalRule = [Append [block]] -fragmentBlock _ block@Pandoc.Null = [Append [block]] -fragmentBlock _ block@(Pandoc.LineBlock _) = [Append [block]] +fragmentBlock _ block@(Pandoc.Header {}) = [Append [block]] +fragmentBlock _ block@(Pandoc.Plain {}) = [Append [block]] +fragmentBlock _ block@(Pandoc.CodeBlock {}) = [Append [block]] +fragmentBlock _ block@(Pandoc.RawBlock {}) = [Append [block]] +fragmentBlock _ block@(Pandoc.DefinitionList {}) = [Append [block]] +fragmentBlock _ block@(Pandoc.Table {}) = [Append [block]] +fragmentBlock _ block@(Pandoc.Div {}) = [Append [block]] +fragmentBlock _ block@Pandoc.HorizontalRule = [Append [block]] +fragmentBlock _ block@Pandoc.Null = [Append [block]] +fragmentBlock _ block@(Pandoc.LineBlock {}) = [Append [block]] fragmentList :: FragmentSettings -- ^ Global settings diff --git a/lib/Patat/PrettyPrint.hs b/lib/Patat/PrettyPrint.hs --- a/lib/Patat/PrettyPrint.hs +++ b/lib/Patat/PrettyPrint.hs @@ -37,27 +37,42 @@ , Alignment (..) , align , paste + + -- * Control codes + , removeControls + , clearScreen + , goToLine ) where -------------------------------------------------------------------------------- -import Control.Monad.Reader (asks, local) -import Control.Monad.RWS (RWS, runRWS) -import Control.Monad.State (get, gets, modify) -import Control.Monad.Writer (tell) -import qualified Data.List as L -import Data.String (IsString (..)) -import qualified Data.Text as T -import Prelude hiding (null) -import qualified System.Console.ANSI as Ansi -import qualified System.IO as IO +import Control.Monad.Reader (asks, local) +import Control.Monad.RWS (RWS, runRWS) +import Control.Monad.State (get, gets, modify) +import Control.Monad.Writer (tell) +import Data.Char.WCWidth.Extended (wcstrwidth) +import qualified Data.List as L +import Data.String (IsString (..)) +import qualified Data.Text as T +import Prelude hiding (null) +import qualified System.Console.ANSI as Ansi +import qualified System.IO as IO -------------------------------------------------------------------------------- +-- | Control actions for the terminal. +data Control + = ClearScreenControl + | GoToLineControl Int + deriving (Eq) + + +-------------------------------------------------------------------------------- -- | A simple chunk of text. All ANSI codes are "reset" after printing. data Chunk = StringChunk [Ansi.SGR] String | NewlineChunk + | ControlChunk Control deriving (Eq) @@ -67,17 +82,21 @@ -------------------------------------------------------------------------------- hPutChunk :: IO.Handle -> Chunk -> IO () -hPutChunk h NewlineChunk = IO.hPutStrLn h "" +hPutChunk h NewlineChunk = IO.hPutStrLn h "" hPutChunk h (StringChunk codes str) = do Ansi.hSetSGR h (reverse codes) IO.hPutStr h str Ansi.hSetSGR h [Ansi.Reset] +hPutChunk h (ControlChunk ctrl) = case ctrl of + ClearScreenControl -> Ansi.hClearScreen h + GoToLineControl l -> Ansi.hSetCursorPosition h l 0 -------------------------------------------------------------------------------- chunkToString :: Chunk -> String chunkToString NewlineChunk = "\n" chunkToString (StringChunk _ str) = str +chunkToString (ControlChunk _) = "" -------------------------------------------------------------------------------- @@ -100,7 +119,7 @@ -------------------------------------------------------------------------------- -data DocE +data DocE d = String String | Softspace | Hardspace @@ -108,27 +127,30 @@ | Hardline | WrapAt { wrapAtCol :: Maybe Int - , wrapDoc :: Doc + , wrapDoc :: d } | Ansi { ansiCode :: [Ansi.SGR] -> [Ansi.SGR] -- ^ Modifies current codes. - , ansiDoc :: Doc + , ansiDoc :: d } | Indent { indentFirstLine :: LineBuffer , indentOtherLines :: LineBuffer - , indentDoc :: Doc + , indentDoc :: d } + | Control Control + deriving (Functor) -------------------------------------------------------------------------------- -chunkToDocE :: Chunk -> DocE +chunkToDocE :: Chunk -> DocE Doc chunkToDocE NewlineChunk = Hardline chunkToDocE (StringChunk codes str) = Ansi (\_ -> codes) (Doc [String str]) +chunkToDocE (ControlChunk ctrl) = Control ctrl -------------------------------------------------------------------------------- -newtype Doc = Doc {unDoc :: [DocE]} +newtype Doc = Doc {unDoc :: [DocE Doc]} deriving (Monoid, Semigroup) @@ -184,7 +206,7 @@ ((), b, cs) = runRWS (go $ unDoc doc0) env0 mempty in optimizeChunks (cs <> bufferToChunks b) where - go :: [DocE] -> DocM () + go :: [DocE Doc] -> DocM () go [] = return () @@ -228,13 +250,18 @@ go (unDoc indentDoc) go docs + go (Control ctrl : docs) = do + tell [ControlChunk ctrl] + go docs + + makeChunk :: String -> DocM Chunk makeChunk str = do codes <- asks deCodes return $ StringChunk codes str -- Convert 'Softspace' or 'Softline' to 'Hardspace' or 'Hardline' - softConversion :: DocE -> [DocE] -> DocM DocE + softConversion :: DocE Doc -> [DocE Doc] -> DocM (DocE Doc) softConversion soft docs = do mbWrapCol <- asks deWrap case mbWrapCol of @@ -242,7 +269,7 @@ Just maxCol -> do -- Slow. currentLine <- gets (concatMap chunkToString . bufferToChunks) - let currentCol = length currentLine + let currentCol = wcstrwidth currentLine case nextWordLength docs of Nothing -> return hard Just l @@ -254,11 +281,11 @@ Softline -> Hardline _ -> soft - nextWordLength :: [DocE] -> Maybe Int + nextWordLength :: [DocE Doc] -> Maybe Int nextWordLength [] = Nothing nextWordLength (String x : xs) | L.null x = nextWordLength xs - | otherwise = Just (length x) + | otherwise = Just (wcstrwidth x) nextWordLength (Softspace : xs) = nextWordLength xs nextWordLength (Hardspace : xs) = nextWordLength xs nextWordLength (Softline : xs) = nextWordLength xs @@ -266,6 +293,7 @@ nextWordLength (WrapAt {..} : xs) = nextWordLength (unDoc wrapDoc ++ xs) nextWordLength (Ansi {..} : xs) = nextWordLength (unDoc ansiDoc ++ xs) nextWordLength (Indent {..} : xs) = nextWordLength (unDoc indentDoc ++ xs) + nextWordLength (Control _ : _) = Nothing -------------------------------------------------------------------------------- @@ -278,7 +306,7 @@ dimensions :: Doc -> (Int, Int) dimensions doc = let ls = lines (toString doc) in - (length ls, foldr max 0 (map length ls)) + (length ls, foldr max 0 (map wcstrwidth ls)) -------------------------------------------------------------------------------- @@ -297,7 +325,7 @@ -------------------------------------------------------------------------------- -mkDoc :: DocE -> Doc +mkDoc :: DocE Doc -> Doc mkDoc e = Doc [e] @@ -379,7 +407,7 @@ -------------------------------------------------------------------------------- align :: Int -> Alignment -> Doc -> Doc align width alignment doc0 = - let chunks0 = docToChunks doc0 + let chunks0 = docToChunks $ removeControls doc0 lines_ = chunkLines chunks0 in vcat [ Doc (map chunkToDocE (alignLine line)) @@ -387,7 +415,7 @@ ] where lineWidth :: [Chunk] -> Int - lineWidth = sum . map (length . chunkToString) + lineWidth = sum . map (wcstrwidth . chunkToString) alignLine :: [Chunk] -> [Chunk] alignLine line = @@ -406,8 +434,26 @@ -- | Like the unix program 'paste'. paste :: [Doc] -> Doc paste docs0 = - let chunkss = map docToChunks docs0 :: [Chunks] - cols = map chunkLines chunkss :: [[Chunks]] - rows0 = L.transpose cols :: [[Chunks]] - rows1 = map (map (Doc . map chunkToDocE)) rows0 :: [[Doc]] in + let chunkss = map (docToChunks . removeControls) docs0 :: [Chunks] + cols = map chunkLines chunkss :: [[Chunks]] + rows0 = L.transpose cols :: [[Chunks]] + rows1 = map (map (Doc . map chunkToDocE)) rows0 :: [[Doc]] in vcat $ map mconcat rows1 + + +-------------------------------------------------------------------------------- +removeControls :: Doc -> Doc +removeControls = Doc . filter isNotControl . map (fmap removeControls) . unDoc + where + isNotControl (Control _) = False + isNotControl _ = True + + +-------------------------------------------------------------------------------- +clearScreen :: Doc +clearScreen = mkDoc $ Control ClearScreenControl + + +-------------------------------------------------------------------------------- +goToLine :: Int -> Doc +goToLine = mkDoc . Control . GoToLineControl diff --git a/lib/Patat/Theme.hs b/lib/Patat/Theme.hs --- a/lib/Patat/Theme.hs +++ b/lib/Patat/Theme.hs @@ -47,6 +47,7 @@ , themeLineBlock :: !(Maybe Style) , themeEmph :: !(Maybe Style) , themeStrong :: !(Maybe Style) + , themeUnderline :: !(Maybe Style) , themeCode :: !(Maybe Style) , themeLinkText :: !(Maybe Style) , themeLinkTarget :: !(Maybe Style) @@ -76,6 +77,7 @@ , themeLineBlock = mplusOn themeLineBlock , themeEmph = mplusOn themeEmph , themeStrong = mplusOn themeStrong + , themeUnderline = mplusOn themeUnderline , themeCode = mplusOn themeCode , themeLinkText = mplusOn themeLinkText , themeLinkTarget = mplusOn themeLinkTarget @@ -97,7 +99,7 @@ mempty = Theme Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing -------------------------------------------------------------------------------- defaultTheme :: Theme @@ -116,6 +118,7 @@ , themeLineBlock = dull Ansi.Magenta , themeEmph = dull Ansi.Green , themeStrong = dull Ansi.Red `mappend` bold + , themeUnderline = dull Ansi.Red `mappend` underline , themeCode = dull Ansi.White `mappend` ondull Ansi.Black , themeLinkText = dull Ansi.Green , themeLinkTarget = dull Ansi.Cyan `mappend` underline diff --git a/patat.cabal b/patat.cabal --- a/patat.cabal +++ b/patat.cabal @@ -1,5 +1,5 @@ Name: patat -Version: 0.8.6.1 +Version: 0.8.7.0 Synopsis: Terminal-based presentations using Pandoc Description: Terminal-based presentations using Pandoc. License: GPL-2 @@ -44,15 +44,16 @@ filepath >= 1.4 && < 1.5, mtl >= 2.2 && < 2.3, optparse-applicative >= 0.12 && < 0.16, - pandoc >= 2.9 && < 2.10, - pandoc-types >= 1.20 && < 1.21, + pandoc >= 2.11 && < 2.12, + pandoc-types >= 1.22 && < 1.23, process >= 1.6 && < 1.7, - skylighting >= 0.1 && < 0.9, + skylighting >= 0.10 && < 0.11, terminal-size >= 0.3 && < 0.4, text >= 1.2 && < 1.3, time >= 1.4 && < 1.10, unordered-containers >= 0.2 && < 0.3, yaml >= 0.8 && < 0.12, + wcwidth >= 0.0 && < 0.1, -- We don't even depend on these packages but they can break cabal install -- because of the conflicting 'Network.URI' module. network-uri >= 2.6, @@ -68,8 +69,9 @@ Patat.Eval Patat.Images Patat.Images.Internal - Patat.Images.W3m Patat.Images.ITerm2 + Patat.Images.Kitty + Patat.Images.W3m Patat.Main Patat.Presentation Patat.Presentation.Display @@ -86,6 +88,7 @@ Other-modules: Data.Aeson.Extended Data.Aeson.TH.Extended + Data.Char.WCWidth.Extended Data.Data.Extended Paths_patat Text.Pandoc.Extended @@ -109,13 +112,13 @@ Buildable: False Build-depends: - base >= 4.9 && < 5, - containers >= 0.6 && < 0.7, - doctemplates >= 0.8 && < 0.9, - mtl >= 2.2 && < 2.3, - pandoc >= 2.9 && < 2.10, - text >= 1.2 && < 1.3, - time >= 1.6 && < 1.10 + base >= 4.9 && < 5, + containers >= 0.6 && < 0.7, + doctemplates >= 0.8 && < 0.9, + mtl >= 2.2 && < 2.3, + pandoc >= 2.11 && < 2.12, + text >= 1.2 && < 1.3, + time >= 1.6 && < 1.10 Test-suite patat-tests Main-is: Main.hs