4 files changed, 65 insertions(+), 25 deletions(-)

M amphiarao.cabal
M src/Main.hs
M src/UI/Search.hs
M src/UI/Templates.hs

@@ 64,11 64,15 @@ executable amphiarao
   
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.9 && <4.10, happstack-lite >=7.3.7 && <7.4, happstack-server,
+        -- For JSON/HTTP APIs
         aeson >= 1.5.0 && <1.6, text, bytestring, unordered-containers, vector,
-        containers >=0.5 && <0.7, uuid >=1.3 && <1.4,
-        blaze-html, xml-conduit >= 1.8 && < 1.9, html-conduit >= 1.3 && <1.4,
+        containers >=0.5 && <0.7, uuid >=1.3 && <1.4, file-embed >= 0.0.9 && < 0.1,
+        -- For HTML UIs
+        blaze-html, blaze-markup,
+        -- Network input
         hurl >= 2.1 && <3, network-uri,
-        css-syntax, array >=0.4
+        -- Parse & query XML/HTML
+        xml-conduit >= 1.8 && < 1.9, html-conduit >= 1.3 && <1.4, css-syntax, array >=0.4
 
   build-tools: happy
   

@@ 1,21 1,24 @@
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-}
 module Main where
 
 import Happstack.Lite
 import Happstack.Server.RqData
 import Control.Concurrent.MVar
 import Data.HashMap.Strict as M
+import Data.FileEmbed
 
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
-import Text.Blaze.Html (text, string)
+import Text.Blaze.Html (text, string, contents)
+import Text.Blaze.Renderer.Text (renderMarkup)
 import qualified Data.Text as Txt
+import Data.Text.Lazy (toStrict)
 
 import Webdriver
 import Data.UUID as ID
 
 import qualified Text.XML.Cursor as XC
-import qualified Text.XML as XML
+import Data.Maybe
 
 import Messages
 import Happstack.Server.I18N


@@ 33,6 36,7 @@ main :: IO ()
 main = do
   sessions <- initSessions
   serve Nothing $ msum [
+      dir "assets" $ path $ ok . toResponse . fromMaybe "Not Found" . flip Prelude.lookup $(embedDir "assets"),
       dir "webdriver" $ dir "v1" $ serveWebdriver sessions,
       postHome sessions,
       serveHome,


@@ 45,7 49,7 @@ serveHome :: ServerPart Response
 serveHome = do
     nullDir
     method GET
-    Tpl.page ok ["Amphiarao"] $ \langs -> do
+    Tpl.page ok ["Amphiarao"] "" $ \langs -> do
         l langs AmphiaraoIntro
         Tpl.sessionForm langs
 


@@ 71,7 75,7 @@ deleteSession sessions uuid = do
 servePreviewPrompt = do
     nullDir
     method GET
-    Tpl.page ok ["?", "Amphiarao"] $ \langs -> H.p $ l langs PromptPreview
+    Tpl.page ok ["?", "Amphiarao"] "" $ \langs -> H.p $ l langs PromptPreview
 
 ---
 


@@ 94,11 98,11 @@ sessionHome session = do
     method GET
 
     session' <- liftIO $ readMVar session
-    Tpl.inspector ok "title" session' $ \langs ->
-        Tpl.xmlNode $ XML.NodeElement $ XML.documentRoot $ document session'
+    Tpl.inspector ok ":root" session' $ \langs ->
+        Tpl.elPage $ XC.fromDocument $ document session'
 
 session404 uuid = do
-    Tpl.page notFound ["404", "Amphiarao"] $ \langs -> do
+    Tpl.page notFound ["404", "Amphiarao"] "" $ \langs -> do
         H.h1 $ l langs SessionNotFound
         Tpl.sessionForm langs
 


@@ 128,8 132,7 @@ searchSession session = do
                     forM results' $ \result -> H.dd $ result langs
                     return ()
                 return ()
-        H.section $ do
-            H.iframe H.! A.src "/preview-prompt" H.! A.name "preview" $ ""
+        H.iframe H.! A.src "/preview-prompt" H.! A.name "preview" $ ""
   where
     labelEmpty [] = [\langs -> l langs NoResults]
     labelEmpty x = x


@@ 175,10 178,11 @@ serveEl uuid session el = do
 serveEl' uuid session' el = do
     nullDir
     method GET
-    Tpl.inspector ok "Element" session' $ \langs -> Tpl.xmlNode $ XC.node el
+    let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el
+    Tpl.inspector ok title session' $ \langs -> Tpl.elPage el
 
 serveElPreview uuid el = do
     nullDir
     method GET
-    Tpl.page ok ["Element", Txt.pack $ ID.toString uuid, "Amphiarao"] $ \langs ->
-        Tpl.xmlNode $ XC.node el
+    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

@@ 14,6 14,7 @@ import Messages
 import Network.URI (parseAbsoluteURI)
 import qualified Internal.Elements as Els
 import qualified Text.XML.Cursor as XC
+import qualified Text.XML as XML
 
 import Control.Monad (mapM)
 import qualified UI.Templates as Tpl


@@ 33,10 34,10 @@ disclosure = "⤷"
 ---
 
 offerToLoad q _ _ | Just _ <- parseAbsoluteURI q = return [\langs -> do
-        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
+            result q $ string q
+            button ! type_ "submit" ! A.title (l' langs DebugLink') $ disclosure
       ]
     | otherwise = return []
 


@@ 45,4 46,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") $ Tpl.xmlNode $ XC.node el
+formatEl (el, uuid) langs = result ("el/" ++ ID.toString uuid ++ "/preview") $ Tpl.xmlNode' $ XC.node el

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


@@ 14,23 15,25 @@ import Control.Concurrent.MVar
 import Data.UUID as ID
 
 import Text.XML (Element(..), Node(..), Instruction(..), Name(..))
+import Text.XML.Cursor as XC
 import qualified Data.Map as M
 
 import Messages
 import Happstack.Server.I18N
 
-page :: (Response -> ServerPart Response) -> [Text] -> ([Text] -> Html) -> ServerPart Response
-page return' title body' = do
+page :: (Response -> ServerPart Response) -> [Text] -> AttributeValue -> ([Text] -> Html) -> ServerPart Response
+page return' title class_ body' = do
     langs <- bestLanguage <$> acceptLanguage
     return' $ toResponse $ html $ do
         H.head $ do
+            link ! rel "stylesheet" ! href "/assets/pantheon.css"
             H.title $ text $ intercalate " — " title
-        body $ body' langs
+        body ! A.class_ class_ $ body' langs
 
 inspector :: (Response -> ServerPart Response) -> Text -> Session' -> ([Text] -> Html) -> ServerPart Response
 inspector return' title session' body' = do
     let timeout = H.stringValue $ show $ pageLoad $ timeouts session'
-    page return' [title, pack $ show $ currentURL $ session', "Amphiarao"] $ \langs -> do
+    page return' [title, pack $ show $ currentURL $ session', "Amphiarao"] "fill" $ \langs -> do
         header $ do
             unless (Prelude.null $ backStack session') $ postButton "/nav/back" (l' langs Back') "🡸"
             unless (Prelude.null $ nextStack session') $ postButton "/nav/next" (l' langs Next') "🡺"


@@ 87,18 90,46 @@ xmlNode (NodeInstruction (Instruction name value)) = do
     stringTok $ unpack value
     symbolTok True "?"
     symbolTok False ">"
-
 xmlNode (NodeContent text) = stringTok $ show text
 xmlNode (NodeComment text) = do
     symbolTok False "<!--"
     commentTok text
     symbolTok False "-->"
 
+xmlNode' (NodeElement el) = elSelector el
+xmlNode' node = xmlNode node
+
+elSelector (Element (Name name _ ns) attrs _) = do
+    -- Yes, token classification isn't a great fit!
+    case ns of
+        Just ns' -> do
+            keywordTok ns'
+            symbolTok False "|"
+        Nothing -> return ()
+    keywordTok name
+    qualifiers "id" "#" identTok
+    qualifiers "class" "." qualifyTok
+    return ()
+  where
+    qualifiers attr symb tok
+        | Just val <- attr `M.lookup` attrs = forM (Txt.words val) $ \val' -> do
+            symbolTok True symb
+            tok val'
+        | otherwise = return []
+
+elPage cursor = blockquote $ do
+    nav $ void $ forM (Prelude.reverse $ XC.ancestor cursor) $ \el -> do
+        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
 
+void act = act >> return ()
 
 symbolTok False = token "symbol silent"
 symbolTok True = token "symbol"
 qualifyTok = token "qualify"
+keywordTok = token "keyword"
 identTok = token "ident"
 stringTok = token "string" . pack
 commentTok = token "comment"