5 files changed, 94 insertions(+), 11 deletions(-)

M src/Internal.hs
M src/Main.hs
M src/Messages.hs
M src/UI/Search.hs
M src/UI/Templates.hs

@@ 1,7 1,7 @@
 {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
 module Internal(Session(..), Session'(..), Sessions(..),
         initSessions, createSession, delSession, getSession, withSession,
-        Timeouts(..), registerEl, serializeEl) where
+        Timeouts(..), registerEl, serializeEl, getEl) where
 
 import qualified Data.HashMap.Strict as M
 import Data.UUID as ID


@@ 100,3 100,6 @@ serializeEl session el = do
     return $ M.fromList [
         ("element-6066-11e4-a52e-4f735466cecf", String $ pack $ ID.toString uuid)
       ]
+
+getEl :: Session' -> UUID -> Maybe XML.Cursor
+getEl session uuid = M.lookup uuid $ knownEls session

@@ 14,6 14,9 @@ import qualified Data.Text as Txt
 import Webdriver
 import Data.UUID as ID
 
+import qualified Text.XML.Cursor as XC
+import qualified Text.XML as XML
+
 import Messages
 import Happstack.Server.I18N
 


@@ 70,6 73,8 @@ servePreviewPrompt = do
     method GET
     Tpl.page ok ["?", "Amphiarao"] $ \langs -> H.p $ l langs PromptPreview
 
+---
+
 serveSession :: Sessions -> String -> ServerPart Response
 serveSession = withSession session404 $ \uuid session -> msum [
         sessionHome session,


@@ 80,7 85,8 @@ serveSession = withSession session404 $ \uuid session -> msum [
             dir "reload" $ reloadPage uuid session,
             dir "back" $ sessionAction' uuid session Load.back,
             dir "next" $ sessionAction' uuid session Load.next
-        ]
+        ],
+        dir "el" $ path $ serveEl uuid session
     ]
 
 sessionHome session = do


@@ 88,10 94,8 @@ sessionHome session = do
     method GET
 
     session' <- liftIO $ readMVar session
-    title <- liftIO $ El.getTitle session
-    Tpl.inspector ok "title" session' $ \langs -> do
-        H.h1 $ text title
-        H.p $ string $ show $ currentURL session'
+    Tpl.inspector ok "title" session' $ \langs ->
+        Tpl.xmlNode $ XML.NodeElement $ XML.documentRoot $ document session'
 
 session404 uuid = do
     Tpl.page notFound ["404", "Amphiarao"] $ \langs -> do


@@ 154,3 158,27 @@ sessionAction' uuid session cb = do
     method POST
     liftIO $ cb session
     seeOther ('/':ID.toString uuid) $ toResponse ()
+
+---
+
+serveEl :: UUID -> Session -> String -> ServerPart Response
+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'
+          ]
+        Nothing -> Tpl.inspector notFound "404" session' $ \langs ->
+            H.h1 $ l langs ElementNotFound
+
+serveEl' uuid session' el = do
+    nullDir
+    method GET
+    Tpl.inspector ok "Element" session' $ \langs -> Tpl.xmlNode $ XC.node el
+
+serveElPreview uuid el = do
+    nullDir
+    method GET
+    Tpl.page ok ["Element", Txt.pack $ ID.toString uuid, "Amphiarao"] $ \langs ->
+        Tpl.xmlNode $ XC.node el

@@ 12,6 12,7 @@ data Message =
     CloseSession |
     LoadTimeout |
     SessionNotFound |
+    ElementNotFound |
     NoResults |
     PromptPreview |
     ErrURL deriving Show


@@ 33,6 34,7 @@ l ("en":_) CreateSession = "Open new test session"
 l ("en":_) LoadTimeout = "Load Timeout"
 l ("en":_) CloseSession = "Close Session"
 l ("en":_) SessionNotFound = "Session Not Found"
+l ("en":_) ElementNotFound = "Element Not Found"
 l ("en":_) NoResults = em "No Results"
 l ("en":_) PromptPreview = em "Click a search result to preview it here"
 l ("en":_) ErrURL = do

@@ 16,6 16,7 @@ import qualified Internal.Elements as Els
 import qualified Text.XML.Cursor as XC
 
 import Control.Monad (mapM)
+import qualified UI.Templates as Tpl
 
 engines :: [(
     [Text] -> Html,


@@ 26,13 27,13 @@ engines = [
     (const "CSS", queryEls "css selector")
   ]
 
-result href' label = a ! href (stringValue href') ! target "preview" $ string label
+result href' = a ! href (stringValue href') ! target "preview"
 disclosure = "⤷"
 
 ---
 
 offerToLoad q _ _ | Just _ <- parseAbsoluteURI q = return [\langs -> do
-        result q q
+        result q $ string q
         H.form ! action "nav/load" ! method "POST" $ do
             input ! type_ "hidden" ! name "url" ! value (stringValue q)
             button ! type_ "submit" ! class_ "disclosure" ! A.title (l' langs DebugLink') $ disclosure


@@ 44,4 45,4 @@ queryEls method q session session'
         Prelude.map formatEl <$> mapM (\el -> (,) el <$> registerEl session el) ret
     | otherwise = return []
 
-formatEl (el, uuid) langs = result ("el/" ++ ID.toString uuid ++ "/preview") $ show $ XC.node el
+formatEl (el, uuid) langs = result ("el/" ++ ID.toString uuid ++ "/preview") $ Tpl.xmlNode $ XC.node el

@@ 1,5 1,5 @@
 {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
-module UI.Templates(page, inspector, sessionForm) where
+module UI.Templates(page, inspector, sessionForm, xmlNode) where
 
 import Happstack.Lite
 import Text.Blaze.Html5 as H


@@ 9,10 9,13 @@ import Data.Text as Txt
 
 import Internal
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad (unless)
+import Control.Monad (unless, when, forM)
 import Control.Concurrent.MVar
 import Data.UUID as ID
 
+import Text.XML (Element(..), Node(..), Instruction(..), Name(..))
+import qualified Data.Map as M
+
 import Messages
 import Happstack.Server.I18N
 


@@ 55,3 58,49 @@ inspector return' title session' body' = do
 sessionForm langs = H.form ! A.method "POST" ! action "/" ! alt (l' langs CreateSession') $ do
     input ! type_ "url" ! name "target" ! placeholder "URL to debug"
     button ! type_ "submit" $ l langs CreateSession
+
+--- XML formatting
+
+xmlNode (NodeElement (Element name attrs childs)) = do
+    symbolTok False "<"
+    ident'Tok name
+    forM (M.toList attrs) $ \(name, value) -> do
+        text " "
+        ident'Tok name
+        symbolTok True "="
+        stringTok $ show value -- quote it!
+    when (Prelude.null childs) $ symbolTok True "/"
+    symbolTok False ">"
+  where
+    ident'Tok (Name tag _ ns) = do
+        case ns of
+            Just ns' -> do
+                qualifyTok ns'
+                symbolTok False ":"
+            Nothing -> return ()
+        identTok tag
+xmlNode (NodeInstruction (Instruction name value)) = do
+    symbolTok False "<"
+    symbolTok True "?"
+    identTok name
+    text " "
+    stringTok $ unpack value
+    symbolTok True "?"
+    symbolTok False ">"
+
+xmlNode (NodeContent text) = stringTok $ show text
+xmlNode (NodeComment text) = do
+    symbolTok False "<!--"
+    commentTok text
+    symbolTok False "-->"
+
+
+
+symbolTok False = token "symbol silent"
+symbolTok True = token "symbol"
+qualifyTok = token "qualify"
+identTok = token "ident"
+stringTok = token "string" . pack
+commentTok = token "comment"
+
+token type_ txt = H.span ! class_ (stringValue ("tok-" ++ type_)) $ text txt