From b32900a7d426f06ee1bd2f69d8cf7899034f5470 Mon Sep 17 00:00:00 2001 From: defanor Date: Thu, 21 Dec 2017 09:23:21 +0300 Subject: Retain position on redisplay, reload, etc Based on line numbers that are attached to document blocks, not dependent on window/terminal width. Some bits can still be refined/refactored, but here's the initial support. --- Pancake.hs | 105 ++++++++++++++++++++++++++++++------------ Pancake/Command.hs | 8 ++++ Pancake/Rendering.hs | 59 ++++++++++++++++++------ README | 3 +- Text/Pandoc/Readers/Gopher.hs | 12 ++--- Text/Pandoc/Readers/Plain.hs | 4 +- pancake.1 | 4 +- pancake.el | 26 ++++++++--- 8 files changed, 161 insertions(+), 60 deletions(-) diff --git a/Pancake.hs b/Pancake.hs index ae6b649..b29e927 100644 --- a/Pancake.hs +++ b/Pancake.hs @@ -66,8 +66,14 @@ import Paths_pancake -- | A zipper kind of thing, for scrolling and history traversal. type Sliding a = ([a], [a]) +-- | A history entry. +data HistoryEntry = HE { hURI :: URI + , hDoc :: P.Pandoc + , hPos :: [Int] + } + -- | Main event loop's state. -data LoopState = LS { history :: Sliding (URI, P.Pandoc) +data LoopState = LS { history :: Sliding HistoryEntry , position :: Int , rendered :: [RendererOutput] , conf :: Config @@ -113,7 +119,7 @@ loadRaw rawURI = do (True, _, _) -> fromMaybe rawURI $ parseAbsoluteURI (unEscapeString $ drop 12 (uriQuery rawURI)) -- handle relative URIs - (_, False, ((cur, _):_, _)) -> relativeTo rawURI cur + (_, False, (h:_, _)) -> relativeTo rawURI (hURI h) _ -> rawURI uScheme = case uriScheme adjustedURI of [] -> "unknown" @@ -179,7 +185,42 @@ goTo t u' = do printDoc uri doc modify $ \s -> let (prev, _) = history s - in s {history = (take (historyDepth $ conf s) $ (uri, doc) : prev, [])} + in s {history = (take (historyDepth $ conf s) $ HE uri doc []:prev, [])} + +-- | Line number to block position. +lineToPos :: [([Int], Int, Int)] -> Int -> [Int] +lineToPos bs n = + case filter (\(p, f, l) -> f <= n && n < l && not (null p)) bs of + [] -> [] + xs -> (\(p, _, _) -> p) $ + maximumBy (\(_, l, _) (_, l', _) -> compare l l') xs + +-- | Block position to line number. +posToLine :: [([Int], Int, Int)] -> [Int] -> Int +posToLine bs p = case filter (\(p', _, _) -> p' == p) bs of + [] -> 1 + ((_, f, _):_) -> f + +-- | Scrolls to a line, which would be at the bottom for CLI. +scrollToLine :: MonadIO m => Int -> StateT LoopState m () +scrollToLine n = get >>= \st -> when (n > position st || embedded st) $ do + -- update history entry's position + case history st of + (h : prev, next) -> modify $ \s -> + s {history = (h {hPos = lineToPos (rBlocks $ rendered st) n}:prev, next)} + _ -> pure () + -- go to line + if embedded st + then putSexpLn ["goto", show n] + else do + showLines $ take (n - position st) $ + drop (position st) (rLines $ rendered st) + modify (\s -> s { position = n }) + +-- | Scrolls to a block's position. +scrollToBlock :: MonadIO m => [Int] -> StateT LoopState m () +scrollToBlock b = get + >>= \s -> scrollToLine $ posToLine (rBlocks $ rendered s) b -- | Evaluates user commands. command :: MonadIO m => Command -> StateT LoopState m () @@ -230,7 +271,7 @@ command (Save (RNumber i) p) = do command (Save RCurrent p) = do st <- get case history st of - ((u, _):_, _) -> command $ Save (RURI u) p + (h:_, _) -> command $ Save (RURI $ hURI h) p _ -> pure () command (GoTo t (RURI u@(URI _ _ _ _ ('#':xs)))) = do -- follow an URI first, if it's not just a fragment @@ -239,17 +280,11 @@ command (GoTo t (RURI u@(URI _ _ _ _ ('#':xs)))) = do _ -> goTo t u -- get to the fragment st <- get - case (lookup xs (rIdentifiers $ rendered st), embedded st) of - (Nothing, _) -> putErrLn $ "Unknown identifier: " ++ xs - (Just x, False) -> do - term <- liftIO setupTermFromEnv - let lineCount = fromMaybe 25 (getCapability term termLines) - when (x + lineCount - 2 > position st) $ do - -- scroll to the given position without skipping anything - showLines $ take (x - position st + lineCount - 2) $ - drop (position st) (rLines $ rendered st) - modify (\s -> s { position = x + lineCount - 2 }) - (Just x, True) -> putSexpLn ["goto", show x] + term <- liftIO setupTermFromEnv + let lineCount = fromMaybe 25 (getCapability term termLines) + maybe (putErrLn $ "Unknown identifier: " ++ xs) + (\pos -> scrollToLine $ if embedded st then pos else pos + lineCount - 2) + (lookup xs (rIdentifiers $ rendered st)) command (GoTo t (RURI u)) = goTo t u command (GoTo t (RNumber i)) = do st <- get @@ -259,37 +294,38 @@ command (GoTo t (RNumber i)) = do command Back = do st <- get case history st of - (cur:p@(uri, d):prev, next) -> do - printDoc uri d + (cur:h:prev, next) -> do + printDoc (hURI h) (hDoc h) + scrollToBlock (hPos h) modify $ \s -> - s { history = (p:prev, take (historyDepth $ conf s) $ cur : next) } + s { history = (h:prev, take (historyDepth $ conf s) $ cur : next) } _ -> putErrLn "There's nothing back there" command Forward = do st <- get case history st of - (prev, n@(uri, d):next) -> do - printDoc uri d + (prev, h:next) -> do + printDoc (hURI h) (hDoc h) + scrollToBlock (hPos h) modify $ \s -> - s { history = (take (historyDepth $ conf s) $ n : prev, next) } + s { history = (take (historyDepth $ conf s) $ h:prev, next) } _ -> putErrLn "Nowhere to go" command More = do st <- get unless (embedded st) $ do term <- liftIO setupTermFromEnv - let lineCount' = fromMaybe 25 (getCapability term termLines) - lineCount = lineCount' - div lineCount' 3 - showLines $ take lineCount $ drop (position st) (rLines $ rendered st) - modify (\s -> s { position = position st + lineCount }) + let lineCount = fromMaybe 25 (getCapability term termLines) + scrollToLine (position st + lineCount - 3) command (GoTo t RCurrent) = do st <- get case history st of - ((u, _):prev, next) -> do - (uri, d) <- loadDocument t u + (h : prev, next) -> do + (uri, d) <- loadDocument t (hURI h) case d of Nothing -> pure () Just doc -> do printDoc uri doc - modify $ \s -> s { history = ( (u, doc):prev, next ) } + scrollToBlock (hPos h) + modify $ \s -> s {history = (HE (hURI h) doc (hPos h) : prev, next)} _ -> putErrLn "There's nothing to reload" command Help = do st <- get @@ -305,7 +341,7 @@ command (Show n) = do command ShowCurrent = do st <- get case history st of - ((u, _):_, _) -> putErrLn $ show u + (h:_, _) -> putErrLn $ show (hURI h) _ -> pure () command (Shortcut u q) = command . GoTo Nothing . RURI . fromJust . parseURI $ u ++ escapeURIString isUnreserved q @@ -317,10 +353,19 @@ command Quit = liftIO $ do command Interrupt = putErrLn "Received SIGINT. Interrupt twice in a row to quit." command (SetWidth w) = modify $ \s -> s { columns = w } +command (SetPos mp) = let p = fromMaybe 0 mp in modify $ \s -> + s { position = p + , history = + case history s of + (h:prev, next) -> + (h { hPos = lineToPos (rBlocks $ rendered s) p } : prev, next) + other -> other} command Redisplay = do st <- get case history st of - ((uri, doc):_, _) -> printDoc uri doc + (h:_, _) -> do + printDoc (hURI h) (hDoc h) + scrollToBlock (hPos h) _ -> putErrLn "There's nothing to redisplay" diff --git a/Pancake/Command.hs b/Pancake/Command.hs index 52ace06..1fd7074 100644 --- a/Pancake/Command.hs +++ b/Pancake/Command.hs @@ -61,6 +61,7 @@ data Command = Quit | Shortcut String String | LoadConfig (Maybe FilePath) | SetWidth (Maybe Int) + | SetPos (Maybe Int) | Redisplay deriving (Show, Eq) @@ -153,6 +154,12 @@ setWidth = string "set width" *> (SetWidth <$> optionMaybe (space *> pNat)) <* eof +-- | 'SetPos' command parser. +setPos :: Parser Command +setPos = string "set position" + *> (SetPos <$> optionMaybe (space *> pNat)) + <* eof + -- | 'LoadConfig' command parser. loadConf :: Parser Command loadConf = string "load config" @@ -171,6 +178,7 @@ command c = , saveCurrent "save current" , save "save" , setWidth "set width" + , setPos "set position" , loadConf "load config" , goTo "follow uri" ]) diff --git a/Pancake/Rendering.hs b/Pancake/Rendering.hs index 6c5a873..778d6f7 100644 --- a/Pancake/Rendering.hs +++ b/Pancake/Rendering.hs @@ -33,6 +33,7 @@ module Pancake.Rendering ( Denotation(..) , rLinks , rLines , rIdentifiers + , rBlocks , rNotes , renderDoc ) where @@ -91,6 +92,7 @@ data RS = RS { indentationLevel :: Int , listing :: Maybe Listing , columns :: Int , rsConf :: Config + , breadcrumbs :: [Int] } deriving (Show, Eq) -- | This is what gets rendered. @@ -98,6 +100,8 @@ data RendererOutput = RLink URI | RNote [RendererOutput] | RLine StyledLine | RIdentifier String Int + | RBlock [Int] Int Int + -- ^ path, start line, end line deriving (Show, Eq) -- | Show a reference. @@ -122,6 +126,12 @@ rIdentifiers [] = [] rIdentifiers (RIdentifier s i:xs) = (s, i) : rIdentifiers xs rIdentifiers (_:xs) = rIdentifiers xs +-- | Extracts block positions. +rBlocks :: [RendererOutput] -> [([Int], Int, Int)] +rBlocks [] = [] +rBlocks (RBlock p s e:xs) = (p, s, e) : rBlocks xs +rBlocks (_:xs) = rBlocks xs + -- | Extracts notes. rNotes :: [RendererOutput] -> [[RendererOutput]] rNotes [] = [] @@ -149,7 +159,7 @@ runRenderer :: Int -- ^ Collected links and text lines. runRenderer cols ls ns ln cnf r = let o = snd $ evalState (runWriterT r) - (RS 0 ls ns ln Nothing cols cnf) + (RS 0 ls ns ln Nothing cols cnf []) in o ++ concatMap (map RLine . rLines) (rNotes o) -- | Stores a link, increasing the counter. @@ -397,20 +407,25 @@ renderBlock :: P.Block -> Renderer () renderBlock (P.Plain i) = indented =<< readInlines i renderBlock (P.Para i) = indented =<< readInlines i renderBlock (P.LineBlock i) = - indented =<< concat <$> mapM (mapM readInline) i + zipWithM_ (\l n -> withBreadcrumb n $ + (pure . concat <$> mapM readInline l) >>= indented) + i [1..] renderBlock (P.CodeBlock attr s) = do storeAttr attr - indented $ map (pure . Fg Green . fromString) $ lines s + zipWithM_ (\l n -> withBreadcrumb n $ indented [l]) + (map (pure . Fg Green . fromString) $ lines s) [1..] renderBlock (P.RawBlock _ s) = indented $ map (pure . fromString) $ lines s renderBlock (P.BlockQuote bs) = withIndent $ renderBlocks bs renderBlock (P.OrderedList _ bs) = do zipWithM_ (\b n -> modify (\s -> s { listing = Just (Ordered n) }) - >> keepIndent (renderBlocks b)) bs [1..] + >> withBreadcrumb n (keepIndent (renderBlocks b))) + bs [1..] modify $ \s -> s { listing = Nothing } renderBlock (P.BulletList bs) = do - mapM_ (\b -> modify (\s -> s { listing = Just Bulleted }) - >> keepIndent (renderBlocks b)) bs + zipWithM_ (\b n -> modify (\s -> s { listing = Just Bulleted }) + >> withBreadcrumb n (keepIndent (renderBlocks b))) + bs [1..] modify $ \s -> s { listing = Nothing } renderBlock (P.DefinitionList dl) = let renderDefinition (term, definition) = do @@ -441,7 +456,9 @@ renderBlock (P.Table caption aligns widths headers rows) = do else fromIntegral l / fromIntegral (sum lens) * 0.7 + 1 / fromIntegral (length lens) * 0.3) lens let withHead = if all null headers then id else (headers :) - mapM_ (\r -> renderBlock P.HorizontalRule >> tableRow ws r) (withHead rows) + zipWithM_ + (\r n -> withBreadcrumb n (renderBlock P.HorizontalRule >> tableRow ws r)) + (withHead rows) [1..] renderBlock P.HorizontalRule where renderCell :: Int -> [P.Block] -> Renderer [RendererOutput] @@ -509,14 +526,30 @@ skipAfter P.Para {} = True skipAfter (P.Div _ bs@(_:_)) = skipAfter $ last bs skipAfter b = isList b +-- | Stores a block position. +withBreadcrumb :: Int -> Renderer a -> Renderer a +withBreadcrumb n r = do + st <- get + let p = n : breadcrumbs st + lineStart = lineNumber st + modify $ \s -> s { breadcrumbs = p } + ret <- r + modify $ \s -> s { breadcrumbs = breadcrumbs st } + st' <- get + tell [RBlock p lineStart (lineNumber st')] + pure ret + -- | Renders block elements with empty lines between some of them. renderBlocks :: [P.Block] -> Renderer () -renderBlocks [] = pure () -renderBlocks [b] = renderBlock b -renderBlocks (b1:bs@(b2:_)) = do - renderBlock b1 - when (skipAfter b1 || skipBefore b2) $ storeLines [[]] - renderBlocks bs +renderBlocks = renderBlocks' 0 + where + renderBlocks' _ [] = pure () + renderBlocks' n [b] = withBreadcrumb n $ renderBlock b + renderBlocks' n (b1:bs@(b2:_)) = do + withBreadcrumb n $ do + renderBlock b1 + when (skipAfter b1 || skipBefore b2) $ storeLines [[]] + renderBlocks' (n + 1) bs -- | Renders a document. renderDoc :: Int diff --git a/README b/README index 7de9384..9cfa437 100644 --- a/README +++ b/README @@ -63,7 +63,7 @@ Commands reload it from the default one :help: show a help message :?: show current URI -:RET (empty): show the next 2/3 of a page, if pagination is enabled +:RET (empty): show the next page, if pagination is enabled :: follow an URI, possibly relative to the current one : : same as above, but explicitly set a document type (html, txt, org, markdown, etc) @@ -75,6 +75,7 @@ Commands : : run a query using a shortcut defined in the configuration (e.g., search) :set width[ ]: set terminal/window width manually +:set position[ ]: set current terminal/window line :redisplay: redisplay current document pancake-mode provides additional aliases and commands, see built-in diff --git a/Text/Pandoc/Readers/Gopher.hs b/Text/Pandoc/Readers/Gopher.hs index 4f90082..6b39d80 100644 --- a/Text/Pandoc/Readers/Gopher.hs +++ b/Text/Pandoc/Readers/Gopher.hs @@ -55,7 +55,7 @@ pInfo = do _ <- manyTill unascii tab _ <- manyTill unascii tab _ <- many1 digit - pure $ mkPrefix "" ++ lineToInlines info ++ [LineBreak] + pure $ mkPrefix "" ++ lineToInlines info -- | A file\/link (i.e., any other than informational) directory -- entry. @@ -81,14 +81,14 @@ pLink = do line = case t of '3' -> prefix ++ lineToInlines name _ -> [Link (name, [], []) (prefix ++ lineToInlines name) (uri, "")] - pure $ line ++ [LineBreak] + pure $ line -- | An erroneous directory entry. Still parsing it, since there is a -- lot of broken directories out there -- but marking as an error. pError :: Parser [Inline] pError = do line <- manyTill anyChar (lookAhead $ try pEOL) - pure $ [Strong $ mkPrefix "error"] ++ lineToInlines line ++ [LineBreak] + pure $ [Strong $ mkPrefix "error"] ++ lineToInlines line -- | Parses last line, with adjustments for what's used in the wild. pLastLine :: Parser () @@ -102,8 +102,8 @@ pEOL = (endOfLine *> pure ()) <|> (tab >> char '+' >> manyTill anyChar endOfLine *> pure ()) -- | Parses a directory. -pDirEntries :: Parser [Inline] -pDirEntries = concat <$> +pDirEntries :: Parser [[Inline]] +pDirEntries = manyTill (choice ([ try pInfo "info entry" , try pLink "link entry" , pError "erroneous entry"]) @@ -115,4 +115,4 @@ readGopher :: PandocMonad m => T.Text -> m Pandoc readGopher s = case parse pDirEntries "directory entry" s of Left err -> throwError $ PandocParseError $ show err - Right r -> pure . Pandoc mempty . pure $ Plain r + Right r -> pure . Pandoc mempty . pure $ LineBlock r diff --git a/Text/Pandoc/Readers/Plain.hs b/Text/Pandoc/Readers/Plain.hs index 3e64b6b..a66b1cd 100644 --- a/Text/Pandoc/Readers/Plain.hs +++ b/Text/Pandoc/Readers/Plain.hs @@ -43,6 +43,6 @@ lineToInlines s = let (cur, next) = break (== ' ') s -- | Reads plain text, always succeeding and producing a single -- 'Plain' block. readPlain :: PandocMonad m => T.Text -> m Pandoc -readPlain = pure . Pandoc mempty . pure . Plain . - concatMap (\l -> (lineToInlines $ T.unpack l) ++ [LineBreak]) +readPlain = pure . Pandoc mempty . pure . LineBlock + . map (\l -> (lineToInlines $ T.unpack l)) . T.lines . T.filter (/= '\r') diff --git a/pancake.1 b/pancake.1 index 38db77a..764b104 100644 --- a/pancake.1 +++ b/pancake.1 @@ -41,7 +41,7 @@ show a help message .IP "\fB?\fR" show current URI .IP "RET (empty)" -show the next 2/3 of a page, if pagination is enabled +show the next page, if pagination is enabled .IP "\fIURI\fR" follow an URI, possibly relative to the current one .IP "\fItype\fR \fIURI\fR" @@ -62,6 +62,8 @@ run a query using a shortcut defined in the configuration (e.g., search) .IP "\fBset width\fR[ \fIcolumns\fR]" set terminal/window width manually +.IP "\fBset position\fR[ \fIline\fR]" +set current terminal/window line .IP "\fBredisplay\fR" redisplay current document diff --git a/pancake.el b/pancake.el index f28b4c2..85fcd94 100644 --- a/pancake.el +++ b/pancake.el @@ -372,16 +372,28 @@ property. Returns a list of collected values." "Sets the width (in columns) that the pancake process should use. Current window width is used if none is provided." (interactive) - ;; Not using `pancake-process-send' here, since it itself would call - ;; this function. - (process-send-string pancake-process - (format "set width %d\n" - (or width (1- (window-width)))))) + (pancake-process-send-raw + (format "set width %d\n" (or width (1- (window-width)))))) + +(defun pancake-position-adjust (&optional line) + "Sets the position (LINE) that the pancake process should use. +Current line is used if none is provided." + (interactive) + (pancake-process-send-raw + (format "set position %d\n" (or line (line-number-at-pos (point)))))) + +(defun pancake-process-send-raw (line) + "Send LINE to the pancake process, without adjusting any +parameters." + (process-send-string pancake-process (concat line "\n"))) (defun pancake-process-send (line) - "Send LINE to the pancake process." + "Send LINE to the pancake process, adjusting width and setting +the current position at once. See `pancake-process-send-raw' for +a version that doesn't do that." (pancake-width-adjust) - (process-send-string pancake-process (concat line "\n"))) + (pancake-position-adjust) + (pancake-process-send-raw line)) (defun pancake-go-backward () "Go backward in history." -- cgit v1.2.3