From 9efe611bed2a0e405b755af34e6acf3906042b60 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sat, 26 Jun 2021 13:31:56 +1200
Subject: [PATCH] Add links for navigating through the XML/HTML tree.

---
 assets/pantheon.css |  2 +-
 src/Internal.hs     | 16 +++++++++++++++-
 src/Main.hs         | 23 +++++++++++++----------
 src/UI/Templates.hs | 13 +++++++++----
 4 files changed, 38 insertions(+), 16 deletions(-)

diff --git a/assets/pantheon.css b/assets/pantheon.css
index cbad00c..a2d4a7e 100644
--- a/assets/pantheon.css
+++ b/assets/pantheon.css
@@ -1,4 +1,4 @@
-/* Styles inspired by elementary OS's Pantheon desktop, & Solarized Light. */
+/* Styles inspired by elementary OS's Pantheon desktop, & Solarized. */
 
 :root {
     --silver100: #fafafa;
diff --git a/src/Internal.hs b/src/Internal.hs
index 243db62..12a0a8a 100644
--- a/src/Internal.hs
+++ b/src/Internal.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
 module Internal(Session(..), Session'(..), Sessions(..),
         initSessions, createSession, delSession, getSession, withSession,
-        Timeouts(..), registerEl, serializeEl, getEl) where
+        Timeouts(..), registerEl, serializeEl, getEl, getRelatedEls) where
 
 import qualified Data.HashMap.Strict as M
 import Data.UUID as ID
@@ -9,6 +9,7 @@ import Data.UUID.V4 as ID
 import Control.Concurrent.MVar
 
 import Control.Monad.IO.Class
+import Control.Monad (mapM)
 
 import Data.Aeson
 import Data.Text (Text, pack)
@@ -103,3 +104,16 @@ serializeEl session el = do
 
 getEl :: Session' -> UUID -> Maybe XML.Cursor
 getEl session uuid = M.lookup uuid $ knownEls session
+
+getRelatedEls session cursor = do
+    session' <- readMVar session
+    let knownEls' = [(XML.node c, uuid) | (uuid, c) <- M.toList $ knownEls session']
+    let elID = elID' knownEls'
+    parents' <- mapM elID $ XML.ancestor cursor
+    self' <- elID cursor
+    childs' <- mapM elID $ XML.child cursor
+    return (self':parents' ++ childs')
+  where
+    elID' knownEls' c | Just id <- c' `Prelude.lookup` knownEls' = return (c', id)
+        | otherwise = (,) c' <$> registerEl session c
+      where c' = XML.node c
diff --git a/src/Main.hs b/src/Main.hs
index 5976ac9..4f48ced 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -81,7 +81,7 @@ servePreviewPrompt = do
 
 serveSession :: Sessions -> String -> ServerPart Response
 serveSession = withSession session404 $ \uuid session -> msum [
-        sessionHome session,
+        sessionHome uuid session,
         dir "timeout" $ setTimeout uuid session,
         dir "search" $ searchSession session,
         dir "nav" $ msum [
@@ -93,13 +93,14 @@ serveSession = withSession session404 $ \uuid session -> msum [
         dir "el" $ path $ serveEl uuid session
     ]
 
-sessionHome session = do
+sessionHome uuid session = do
     nullDir
     method GET
 
     session' <- liftIO $ readMVar session
-    Tpl.inspector ok ":root" session' $ \langs ->
-        Tpl.elPage $ XC.fromDocument $ document session'
+    let el = XC.fromDocument $ document session'
+    related <- liftIO $ getRelatedEls session el
+    Tpl.inspector ok ":root" session' $ \langs -> Tpl.elPage uuid el related
 
 session404 uuid = do
     Tpl.page notFound ["404", "Amphiarao"] "" $ \langs -> do
@@ -167,20 +168,22 @@ serveEl uuid session el = do
     session' <- liftIO $ readMVar session
     case getEl session' =<< ID.fromString el of
         Just el' -> msum [
-            dir "preview" $ serveElPreview uuid el',
-            serveEl' uuid session' el'
+            dir "preview" $ serveElPreview uuid session el',
+            serveEl' uuid session session' el'
           ]
         Nothing -> Tpl.inspector notFound "404" session' $ \langs ->
             H.h1 $ l langs ElementNotFound
 
-serveEl' uuid session' el = do
+serveEl' uuid session session' el = do
     nullDir
     method GET
     let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el
-    Tpl.inspector ok title session' $ \langs -> Tpl.elPage el
+    related <- liftIO $ getRelatedEls session el
+    Tpl.inspector ok title session' $ \langs -> Tpl.elPage uuid el related
 
-serveElPreview uuid el = do
+serveElPreview uuid session el = do
     nullDir
     method GET
     let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el
-    Tpl.page ok [title, Txt.pack $ ID.toString uuid, "Amphiarao"] "fill" $ \langs -> Tpl.elPage el
+    related <- liftIO $ getRelatedEls session el
+    Tpl.page ok [title, Txt.pack $ ID.toString uuid, "Amphiarao"] "fill" $ \langs -> Tpl.elPage uuid el related
diff --git a/src/UI/Templates.hs b/src/UI/Templates.hs
index d3d2ebc..00d0519 100644
--- a/src/UI/Templates.hs
+++ b/src/UI/Templates.hs
@@ -119,12 +119,17 @@ elSelector (Element (Name name _ ns) attrs _) = do
             tok val'
         | otherwise = return []
 
-elPage cursor = blockquote $ do
+elPage uuid cursor links = blockquote $ do
     nav $ void $ forM (Prelude.reverse $ XC.ancestor cursor) $ \el -> do
-        xmlNode' $ XC.node el -- Should all be elements...
+        link el $ xmlNode' $ XC.node el -- Should all be elements...
         symbolTok False " > "
-    p $ xmlNode $ XC.node cursor
-    ol $ void $ forM (XC.child cursor) $ \el -> li $ xmlNode $ XC.node el
+    link cursor $ p $ xmlNode $ XC.node cursor
+    ol $ void $ forM (XC.child cursor) $ \el -> li $ link el $ xmlNode $ XC.node el
+  where
+    link el | Just uuid' <- Prelude.lookup (XC.node el) links =
+            a ! target "_top" ! href (stringValue $ href' uuid')
+        | otherwise = H.span -- Shouldn't happen...
+    href' el = '/':ID.toString uuid ++ "/el/" ++ (ID.toString el)
 
 void act = act >> return ()
 
-- 
2.30.2