summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-21 09:23:21 +0300
committerdefanor <defanor@uberspace.net>2017-12-21 09:23:21 +0300
commitb32900a7d426f06ee1bd2f69d8cf7899034f5470 (patch)
tree33496f0d50e87b286da038973cb294079da3dafc
parentdbd5740dea0ad6119cbef2b3b1cccf1e865beaca (diff)
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.
-rw-r--r--Pancake.hs105
-rw-r--r--Pancake/Command.hs8
-rw-r--r--Pancake/Rendering.hs59
-rw-r--r--README3
-rw-r--r--Text/Pandoc/Readers/Gopher.hs12
-rw-r--r--Text/Pandoc/Readers/Plain.hs4
-rw-r--r--pancake.14
-rw-r--r--pancake.el26
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
:<URI>: follow an URI, possibly relative to the current one
:<type> <URI>: same as above, but explicitly set a document type
(html, txt, org, markdown, etc)
@@ -75,6 +75,7 @@ Commands
:<shortcut> <query>: run a query using a shortcut defined in the
configuration (e.g., search)
:set width[ <columns>]: set terminal/window width manually
+:set position[ <line>]: 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."