patat 0.8.6.1 → 0.8.7.0
raw patch · 13 files changed
+323/−168 lines, 13 filesdep +wcwidthdep ~pandocdep ~pandoc-typesdep ~skylighting
Dependencies added: wcwidth
Dependency ranges changed: pandoc, pandoc-types, skylighting
Files
- CHANGELOG.md +8/−0
- README.md +4/−1
- lib/Data/Char/WCWidth/Extended.hs +9/−0
- lib/Patat/Images.hs +2/−0
- lib/Patat/Images/Kitty.hs +46/−0
- lib/Patat/Images/W3m.hs +13/−5
- lib/Patat/Main.hs +23/−5
- lib/Patat/Presentation.hs +5/−0
- lib/Patat/Presentation/Display.hs +107/−103
- lib/Patat/Presentation/Fragment.hs +11/−11
- lib/Patat/PrettyPrint.hs +76/−30
- lib/Patat/Theme.hs +4/−1
- patat.cabal +15/−12
CHANGELOG.md view
@@ -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
README.md view
@@ -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
+ lib/Data/Char/WCWidth/Extended.hs view
@@ -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
lib/Patat/Images.hs view
@@ -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) ]
+ lib/Patat/Images/Kitty.hs view
@@ -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) ""
lib/Patat/Images/W3m.hs view
@@ -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"
lib/Patat/Main.hs view
@@ -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
lib/Patat/Presentation.hs view
@@ -4,6 +4,11 @@ , Presentation (..) , readPresentation++ , Size+ , getDisplaySize++ , Display (..) , displayPresentation , displayPresentationError , dumpPresentation
lib/Patat/Presentation/Display.hs view
@@ -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) =
lib/Patat/Presentation/Fragment.hs view
@@ -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
lib/Patat/PrettyPrint.hs view
@@ -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
lib/Patat/Theme.hs view
@@ -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
patat.cabal view
@@ -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