From 3f4c70e68bf7723192e8a3f1caa1f22b1d72a256 Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Sun, 5 Nov 2017 13:36:57 +0300
Subject: Provide current URI to pancake-mode

And add a command for displaying and copying it.
---
 Pancake.hs          | 24 ++++++++++++------------
 Pancake/Printing.hs |  7 ++++---
 pancake.el          | 13 +++++++++++++
 3 files changed, 29 insertions(+), 15 deletions(-)

diff --git a/Pancake.hs b/Pancake.hs
index 619b0f8..ef0d7d1 100644
--- a/Pancake.hs
+++ b/Pancake.hs
@@ -52,8 +52,8 @@ data LoopState = LS { history :: Sliding (URI, P.Pandoc)
                     } deriving (Show)
 
 -- | Renders a parsed document.
-printDoc :: MonadIO m => P.Pandoc -> StateT LoopState m ()
-printDoc doc = do
+printDoc :: MonadIO m => URI -> P.Pandoc -> StateT LoopState m ()
+printDoc uri doc = do
   term <- liftIO setupTermFromEnv
   st <- get
   let cols = maybe 80 id $ getCapability term termColumns
@@ -61,7 +61,7 @@ printDoc doc = do
       textLines = rLines l
   modify (\s -> s { rendered = l })
   if embedded st
-    then showSexps l
+    then showSexps uri l
     else do
     let rows = maybe 25 id (getCapability term termLines) - 1
     showLines $ if paginate (conf st)
@@ -137,14 +137,14 @@ loadDocument sType rawURI = do
 -- | Visits an URI, updates history accordingly.
 goTo :: MonadIO m => Maybe String -> URI -> StateT LoopState m ()
 goTo t u' = do
-  (u, d) <- loadDocument t u'
+  (uri, d) <- loadDocument t u'
   case d of
     Nothing -> pure ()
     Just doc -> do
-      printDoc doc
+      printDoc uri doc
       modify $ \s ->
         let (prev, _) = history s
-        in s { history = (take (historyDepth $ conf s) $ (u, doc) : prev, []) }
+        in s {history = (take (historyDepth $ conf s) $ (uri, doc) : prev, [])}
 
 -- | Evaluates user commands.
 command :: MonadIO m => Command -> StateT LoopState m ()
@@ -175,16 +175,16 @@ command (Follow i) = do
 command Back = do
   st <- get
   case history st of
-    (cur:p@(_, d):prev, next) -> do
-      printDoc d
+    (cur:p@(uri, d):prev, next) -> do
+      printDoc uri d
       modify $ \s ->
         s { history = (p:prev, take (historyDepth $ conf s) $ cur : next) }
     _ -> liftIO $ putErrLn "There's nothing back there"
 command Forward = do
   st <- get
   case history st of
-    (prev, n@(_, d):next) -> do
-      printDoc d
+    (prev, n@(uri, d):next) -> do
+      printDoc uri d
       modify $ \s ->
         s { history = (take (historyDepth $ conf s) $ n : prev, next) }
     _ -> liftIO $ putErrLn "Nowhere to go"
@@ -200,11 +200,11 @@ command Reload = do
   st <- get
   case history st of
     ((u, _):prev, next) -> do
-      (_, d) <- loadDocument Nothing u
+      (uri, d) <- loadDocument Nothing u
       case d of
         Nothing -> pure ()
         Just doc -> do
-          printDoc doc
+          printDoc uri doc
           modify $ \s -> s { history = ( (u, doc):prev, next ) }
     _ -> putErrLn "There's nothing to reload"
 command Help = do
diff --git a/Pancake/Printing.hs b/Pancake/Printing.hs
index 9790a6b..a385751 100644
--- a/Pancake/Printing.hs
+++ b/Pancake/Printing.hs
@@ -51,8 +51,8 @@ putSexpLn s = liftIO $ do
   hFlush stdout
 
 -- | Prints rendered lines as s-expressions.
-showSexps :: MonadIO m => [RendererOutput] -> m ()
-showSexps ro =
+showSexps :: MonadIO m => URI -> [RendererOutput] -> m ()
+showSexps uri ro =
   -- would be nicer to use some library for this, but they tend to be
   -- abandoned, and the task is simple enough to do it here
   putSexpLn [ "render"
@@ -62,7 +62,8 @@ showSexps ro =
             , list $ "identifiers"
               : map (\(i, l) -> list [encodeStr i, show l]) (rIdentifiers ro)
             , list $ "links"
-              : map (\uri -> encodeStr $ uriToString id uri "") (rLinks ro)]
+              : map (\u -> encodeStr $ uriToString id u "") (rLinks ro)
+            , list ["uri", ".", encodeStr $ uriToString id uri ""]]
   where
     encodeStr s = concat ["\"", concatMap escape s, "\""]
     escape '\\' = "\\\\"
diff --git a/pancake.el b/pancake.el
index 1119f20..61cb7c5 100644
--- a/pancake.el
+++ b/pancake.el
@@ -113,6 +113,10 @@
   "Pancake browser process.")
 (make-variable-buffer-local 'pancake-process)
 
+(defvar pancake-current-uri nil
+  "Current URI.")
+(make-variable-buffer-local 'pancake-current-uri)
+
 ;;###autoload
 (defun pancake ()
   "Run the pancake browser."
@@ -201,6 +205,7 @@
                  (delete-region (point-min) (point-max))
                  ;; todo: maybe store identifiers and links for
                  ;; further manipulation
+                 (setq pancake-current-uri (alist-get 'uri alist))
                  (dolist (line (alist-get 'lines alist))
                    (insert (pancake-print-line line))
                    (newline))
@@ -271,6 +276,13 @@
   (interactive)
   (pancake-process-send "r"))
 
+(defun pancake-display-current-uri ()
+  "Display current URI and put it into the kill ring."
+  (interactive)
+  (when pancake-current-uri
+    (message "%s" pancake-current-uri)
+    (kill-new pancake-current-uri)))
+
 (defun pancake-input (string)
   "Pancake input handler: opens minibuffer for input.
 Sets the initial contents to STRING, reads the rest, and passes
@@ -290,6 +302,7 @@ it to `pancake-process' as input."
     (define-key map (kbd "C-y") 'pancake-yank)
     (define-key map (kbd "<mouse-2>") 'pancake-yank-primary)
     (define-key map (kbd "C-c C-c") 'pancake-interrupt)
+    (define-key map (kbd "C-c C-u") 'pancake-display-current-uri)
     (define-key map (kbd "B") 'pancake-go-backward)
     (define-key map (kbd "F") 'pancake-go-forward)
     (define-key map (kbd "Q") 'pancake-quit)
-- 
cgit v1.2.3