From 3c9a0247861ad8f7002cb38c48227901fd98de3e Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Tue, 31 Oct 2017 03:23:38 +0300
Subject: Implement document reloading

---
 Pancake.hs | 36 +++++++++++++++++++++++++++---------
 README.org |  2 +-
 pancake.el |  6 ++++++
 3 files changed, 34 insertions(+), 10 deletions(-)

diff --git a/Pancake.hs b/Pancake.hs
index 014462c..b4e654e 100644
--- a/Pancake.hs
+++ b/Pancake.hs
@@ -506,9 +506,10 @@ renderDoc (P.Pandoc _ blocks) = do
     showLines shownLines
     modify (\s -> s { display = ([], shownLines, nextLines) })
 
--- | Evaluates user commands.
-command :: MonadIO m => Command -> StateT LoopState m ()
-command (GoTo u') = do
+-- | Decides what to do with a given URI; either returns a document or
+-- runs an external viewer. Used by both 'GoTo' and 'Reload'.
+loadDocument :: MonadIO m => URI -> StateT LoopState m (URI, Maybe P.Pandoc)
+loadDocument u' = do
   st <- get
   let ddg = isPrefixOf "/l/?kh=-1&uddg=" $ uriToString id u' ""
       u = case (ddg, uriIsAbsolute u', history st) of
@@ -518,10 +519,10 @@ command (GoTo u') = do
             (_, False, (_, [(cur, _)], _)) -> relativeTo u' cur
             _ -> u'
       cmd = maybe (defaultCommand $ conf st) id (M.lookup (init $ uriScheme u) (commands $ conf st))
+      ext = case takeExtension $ uriPath u of
+        ('.':xs) -> map toLower xs
+        other -> other
   d <- liftIO $ do
-    let ext = case takeExtension $ uriPath u of
-          ('.':xs) -> map toLower xs
-          other -> other
     case M.lookup ext (externalViewers $ conf st) of
       Nothing -> do
         doc <- readDoc cmd u
@@ -547,9 +548,15 @@ command (GoTo u') = do
           when (ec /= ExitSuccess) $
             putErrLn $ concat ["An error occured. Exit code: ", show ec]
         pure mzero
+  pure (u, d)
+
+-- | Evaluates user commands.
+command :: MonadIO m => Command -> StateT LoopState m ()
+command (GoTo u') = do
+  (u, d) <- loadDocument u'
   case d of
     Nothing -> pure ()
-    Just doc@(P.Pandoc _ _) -> do
+    Just doc -> do
       renderDoc doc
       modify $ \s ->
         let (prev, cur, _) = history s
@@ -588,11 +595,22 @@ command More = do
       showLines newLines
       modify (\s -> s { display = (reverse cur ++ prev, newLines, next') })
       pure ()
-command Reload = liftIO $ putErrLn "Not implemented yet (TODO)"
+command Reload = do
+  st <- get
+  case history st of
+    (_, [(u, _)], _) -> do
+      (_, d) <- loadDocument u
+      case d of
+        Nothing -> pure ()
+        Just doc -> do
+          renderDoc doc
+          modify $ \s -> let (prev, _, next) = history s
+                         in s { history = ( prev, [(u, doc)], next ) }
+    _ -> putErrLn "There's nothing to reload"
 command Help = do
   st <- get
   liftIO $ do
-    putErrLn "[q]uit, [b]ack, [f]orward, [h]elp, [re]load config"
+    putErrLn "[q]uit, [b]ack, [f]orward, [h]elp, [r]eload, [re]load config"
     putErrLn "type a number to follow a link, \"<number>?\" to print its URI"
     putErrLn "type an URI (absolute or relative) to open it"
     when (paginate $ conf st) $ putErrLn "RET to scroll"
diff --git a/README.org b/README.org
index da42cac..a2b1b71 100644
--- a/README.org
+++ b/README.org
@@ -22,7 +22,7 @@ your default emacs browser:
 
 * Commands
 
-- [q]uit, [b]ack, [f]orward, [h]elp, [re]load config
+- [q]uit, [b]ack, [f]orward, [h]elp, [r]eload, [re]load config
 - <number>: follow a link (or open the referenced file)
 - <number>?: show link/image URI
 - ?: show current URI
diff --git a/pancake.el b/pancake.el
index c23b19e..392ccaa 100644
--- a/pancake.el
+++ b/pancake.el
@@ -269,6 +269,11 @@
   (interactive)
   (pancake-process-send "q"))
 
+(defun pancake-reload ()
+  "Reload the current document."
+  (interactive)
+  (pancake-process-send "r"))
+
 (defun pancake-input (string)
   "Pancake input handler: opens minibuffer for input.
 Sets the initial contents to STRING, reads the rest, and passes
@@ -291,6 +296,7 @@ it to `pancake-process' as input."
     (define-key map (kbd "B") 'pancake-go-backward)
     (define-key map (kbd "F") 'pancake-go-forward)
     (define-key map (kbd "Q") 'pancake-quit)
+    (define-key map (kbd "R") 'pancake-reload)
     map)
   "Keymap for `pancake-mode'.")
 
-- 
cgit v1.2.3