4 files changed, 38 insertions(+), 16 deletions(-)

M assets/pantheon.css
M src/Internal.hs
M src/Main.hs
M src/UI/Templates.hs

@@ 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;

@@ 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

@@ 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

@@ 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 ()