[Fencommits] fenserve: colorize and link rendered potion segments

Wed Jun 20 03:21:22 EEST 2007

Wed Jun 20 03:21:02 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * colorize and link rendered potion segments
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs

--- old-fenserve/fendata/Main.hs	2007-06-20 03:21:22.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-06-20 03:21:22.000000000 +0300
@@ -32,7 +32,18 @@
     (Control.Exception.evaluate (length (show x) `seq` Right x))
     (\e -> return $ Left $ "Internal server error: " ++ show e)
     
-header = HTML "<head><style>a.editLink { text-decoration: none; color: inherit}</style></head>"
+header = HTML $ concatMap (++"\n") $
+  [ "<head><style>"
+  , "a.editLink { text-decoration: none; color: inherit }"
+  , ".potion {"
+  , "    border: dashed black 1px; padding: 2px;"
+  , "    margin: 2px; line-height: 1.8em }"
+  , "span.potion { background: #eee }"
+  , "span.potion span.potion { background: #ddd }"
+  , "span.potion span.potion span.potion { background: #ccc }"
+  , "span.potion span.potion span.potion span.potion { background: #bbb }"
+  , "span.potion span.potion span.potion span.potion span.potion { background: #aaa }"
+  , "</style></head>" ]
     
 page path _ content = h (path :: [String]) GET $ ok $ \() () -> respond $
     either id id $ evaluate (html $ header & content)
diff -rN -u old-fenserve/fendata/Rendering.hs new-fenserve/fendata/Rendering.hs
--- old-fenserve/fendata/Rendering.hs	2007-06-20 03:21:22.000000000 +0300
+++ new-fenserve/fendata/Rendering.hs	2007-06-20 03:21:22.000000000 +0300
@@ -14,7 +14,7 @@
 
 import Data.Generics
 import Data.Int
-import Data.List (intersperse)
+import Data.List (intersperse, isPrefixOf)
 import Data.Map (Map)
 import Data.Maybe (fromMaybe)
 import qualified Data.Map as Map
@@ -85,12 +85,17 @@
 
 
 renderExp :: (?db :: DB, ?time :: Int64) => (String -> Potion) -> Exp -> HTML
-renderExp getPotion exp = f $ execWriter $ flip runStateT 0 $ runReaderT (renderExp' getPotion exp) $ Env [] [] exp where
-    f ((p,h):(q,i):xs) | p == q = f ((p,h&i):xs)
-    f ((p,h):xs) = (& f xs) $ flip (tag "a") h 
+renderExp getPotion exp = potion $ fst $ f [] (HTML "") $ execWriter $ flip runStateT 0 $ runReaderT (renderExp' getPotion exp) $ Env [] [] exp where
+    potion = tag "span" [P "class" "potion"]
+    lnk p = tag "a"
       [ P "class" "editLink"
       , P "href" $ "/path/" ++ concat (intersperse "." (map show p)) ]
-    f [] = HTML ""
+      
+    f p h ((q,i):(r,j):xs) | q == r = f p h ((q,i&j):xs)
+    f p h ((q,i):xs) | p == q           = f p (h & lnk p i) xs
+                     | p `isPrefixOf` q = let (i',xs') = f q (HTML "") ((q,i):xs)
+                                           in f p (h & potion i') xs'
+    f p h xs = (h,xs)
     
 renderExp' :: (?db :: DB, ?time :: Int64) => (String -> Potion) -> Exp -> RenderExp ()
 renderExp' getPotion exp@(Exp n arg) = f (getPotion n) where


