[Fencommits] fenserve: a bit more from last tuesday

[Benja Fallenstein]

Sat May 19 15:39:57 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * a bit more from last tuesday
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-05-19 16:12:33.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-05-19 16:12:33.000000000 +0300
@@ -63,22 +63,30 @@
          | Str String
     deriving (Read, Show, Typeable, Data)
 
-renderExp :: (?state :: MyState) => Exp -> String
-renderExp (Call fname args) = f (funTypes fun) (funParts fun) args where
+editLink :: (Exp -> Exp) -> Exp -> String -> String
+editLink f old s = "<a href='edit?exp=" ++ quote (show $ f $ Var (-1))
+                ++ "&amp;old=" ++ quote (show old) ++ "'>" ++ s ++ "</a>"
+
+renderExpL exp cx = editLink cx exp $ renderExp exp cx
+renderExpL' exp cx = editLink cx exp $ renderExp' exp cx
+
+renderExp :: (?state :: MyState) => Exp -> (Exp -> Exp) -> String
+renderExp (Call fname args) cx = f (funTypes fun) (funParts fun) args 0 where
     fun = readFun ?state fname
-    f []     [x]    _      = x
-    f (t:ts) (x:xs) (y:ys) = 
-        x ++ maybe (surround $ "<b style='color: maroon'>[" ++ typeQuestion t ++ "]</b>") renderExp' y ++ f ts xs ys
-renderExp (Var i) = renderVar i
-renderExp (Forall i exp body) = "For each " ++ renderExp' exp
+    cx' n e = cx $ Call fname $ take n args ++ [Just e] ++ drop (n-1) args
+    f []     [x]    _      n = x
+    f (t:ts) (x:xs) (y:ys) n = 
+        x ++ maybe (editLink (cx' n) (Var 0) $ surround $ "<b style='color: maroon'>[" ++ typeQuestion t ++ "]</b>") (flip renderExpL' $ cx' n) y ++ f ts xs ys (n+1)
+renderExp (Var i) _ = renderVar i
+renderExp (Forall i exp body) cx = "For each " ++ renderExpL' exp (\e -> cx $ Forall i e body)
                              ++ " " ++ renderVar i ++ ":\n"
-                             ++ "<blockquote>\n" ++ renderExp body
+                             ++ "<blockquote>\n" ++ renderExpL body (\e -> cx $ Forall i exp e)
                              ++ "</blockquote>"
-renderExp (Str s) = "\"" ++ quote s ++ "\""
-renderExp (HTML exps) = concatMap (\e -> "<p>" ++ renderExp' e ++ "\n") exps
+renderExp (Str s) cx = "\"" ++ quote s ++ "\""
+renderExp (HTML exps) cx = concatMap (\i -> "<p>" ++ renderExpL' (exps!!i) (\e -> cx $ HTML $ take i exps ++ [e] ++ drop (i+1) exps) ++ "\n") [0..length exps-1]
 
-renderExp' e@(Str _) = renderExp e
-renderExp' e = surround (renderExp e)
+renderExp' e@(Str _) cx = renderExp e cx
+renderExp' e cx = surround (renderExp e cx)
 
 surround s = "<span style='border: dashed black 1px; padding: 2px; margin: 2px'>" ++ s ++ "</span>"
 
@@ -202,7 +210,7 @@
            ++ concatMap category (Map.toList $ stateSchema state) 
     -}
     respond $ concatFor (getPotions state) $ \exp ->
-        "<p>" ++ let ?state = state in renderExp exp ++ "\n"
+        "<p>" ++ let ?state = state in renderExp exp id ++ "\n"
            
 instance FromMessage (String,String) where
     fromMessageM m = do cat <- lookM m "category"; name <- lookM m "name" 
@@ -264,7 +272,7 @@
     ("<p>Select something to replace '" ++ show old ++ "' with.\n<hr>\n" ++
      (concatFor (getPotions s) $ \repl ->
           "<p><li><a href='potion?exp=" ++ show (subst (-1) repl exp) ++
-          "'>" ++ let ?state = s in renderExp repl ++ "</a>\n")
+          "'>" ++ let ?state = s in renderExp repl id ++ "</a>\n")
     , s)
 
 main = stdHTTP [ debugFilter
@@ -274,7 +282,7 @@
                              Just e -> " [<a href='?exp="++quote (show e)++"'>"
                                     ++ "expand definition</a>]"
                              Nothing -> ""
-                     in (let ?state=s in renderExp exp ++ lnk ++ "<hr>\n"
+                     in (let ?state=s in renderExp exp id ++ lnk ++ "<hr>\n"
                            ++ if (isComplete exp)
                                 then (head $ evalStateT (runExp env exp) s)
                                 else "(Incomplete expression.)", s)
@@ -283,7 +291,7 @@
                          (r,s') = case runStateT (runExp env exp) s of
                              [result] -> result
                              xs -> ("Wrong number of results: "++show xs, s)
-                     in (let ?state=s in renderExp exp ++ "<hr>\n" ++ r, s')
+                     in (let ?state=s in renderExp exp id ++ "<hr>\n" ++ r, s')
                , h (Prefix ["edit"]) GET $ ok $ \() -> run edit
 
                , h () GET  $ ok $ \() () -> view