[Fencommits] fenserve: I can edit potions :-)

[Benja Fallenstein]

Sat May 19 16:12:21 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * I can edit potions :-)
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,27 +63,25 @@
          | Str String
     deriving (Read, Show, Typeable, Data)
 
-editLink :: (Exp -> Exp) -> Exp -> String -> String
-editLink f old s = "<a href='edit?exp=" ++ quote (show $ f $ Var (-1))
+editLink :: (?link :: Bool) => (Exp -> Exp) -> Exp -> String -> String
+editLink f old s | not ?link = s | otherwise =
+                   "<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
+renderExp :: (?state :: MyState, ?link :: Bool) => Exp -> (Exp -> Exp) -> String
+renderExp exp@(Call fname args) cx = f (funTypes fun) (funParts fun) args 0 where
     fun = readFun ?state fname
-    cx' n e = cx $ Call fname $ take n args ++ [Just e] ++ drop (n-1) args
-    f []     [x]    _      n = x
+    cx' n e = cx $ Call fname $ take n args ++ [Just e] ++ drop (n+1) args
+    f []     [x]    _      n = editLink cx exp 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)
+        editLink cx exp x ++ maybe (editLink (cx' n) (Var 0) $ surround $ "<b style='color: maroon'>[" ++ typeQuestion t ++ "]</b>") (flip renderExp' $ cx' n) y ++ f ts xs ys (n+1)
+renderExp exp@(Var i) cx = editLink cx exp (renderVar i)
+renderExp (Forall i exp body) cx = "For each " ++ renderExp' exp (\e -> cx $ Forall i e body)
                              ++ " " ++ renderVar i ++ ":\n"
-                             ++ "<blockquote>\n" ++ renderExpL body (\e -> cx $ Forall i exp e)
+                             ++ "<blockquote>\n" ++ renderExp body (\e -> cx $ Forall i exp e)
                              ++ "</blockquote>"
-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 (Str s) cx = "<small>" ++ quoteP s ++ "</small>"
+renderExp (HTML exps) cx = "<p>" ++ concatMap (\i -> renderExp' (exps!!i) (\e -> cx $ HTML $ take i exps ++ [e] ++ drop (i+1) exps)) [0..length exps-1]
 
 renderExp' e@(Str _) cx = renderExp e cx
 renderExp' e cx = surround (renderExp e cx)
@@ -91,12 +89,12 @@
 surround s = "<span style='border: dashed black 1px; padding: 2px; margin: 2px'>" ++ s ++ "</span>"
 
 
-quote "" = ""
-quote ('<':cs) = "&lt;" ++ quote cs
-quote ('"':cs) = "&quot;" ++ quote cs
-quote ('\'':cs) = "&apos;" ++ quote cs
-quote ('&':cs) = "&amp;" ++ quote cs
-quote (c:cs) = c : quote cs
+quote = concatMap quoteChar
+quoteBr = concatMap (\c -> case c of '\n' -> "<br>"; _ -> quoteChar c)
+quoteP = concatMap (\c -> case c of '\n' -> "<p>"; _ -> quoteChar c)
+
+quoteChar c = case c of '<' -> "&lt;"; '"' -> "&quot;"; '\'' -> "&apos;"
+                        '&' -> "&amp;"; _ -> [c]
 
 renderVar i = "<i>" ++ [toEnum (fromEnum 'a' + i)] ++ "</i>"
 
@@ -210,7 +208,7 @@
            ++ concatMap category (Map.toList $ stateSchema state) 
     -}
     respond $ concatFor (getPotions state) $ \exp ->
-        "<p>" ++ let ?state = state in renderExp exp id ++ "\n"
+        "<p>" ++ let ?state = state; ?link=False in renderExp exp id ++ "\n"
            
 instance FromMessage (String,String) where
     fromMessageM m = do cat <- lookM m "category"; name <- lookM m "name" 
@@ -270,10 +268,13 @@
 edit :: (Exp,Exp) -> MyState -> (String, MyState)
 edit (exp,old) s =
     ("<p>Select something to replace '" ++ show old ++ "' with.\n<hr>\n" ++
+    ("<p>Variables: " ++ concat [link (Var i) (renderVar i) ++ " " 
+                                | i <- [0..25]]) ++
      (concatFor (getPotions s) $ \repl ->
-          "<p><li><a href='potion?exp=" ++ show (subst (-1) repl exp) ++
-          "'>" ++ let ?state = s in renderExp repl id ++ "</a>\n")
-    , s)
+          "<p><li>" ++ (link repl $ let ?state = s; ?link=False 
+                                     in renderExp repl id) ++ "\n")
+    , s) where link new s = "<a href='potion?exp=" ++ show (subst (-1) new exp)
+                         ++ "'>" ++ s ++ "</a>"
 
 main = stdHTTP [ debugFilter
                , h (Prefix ["potion"]) GET $ ok $ \() -> run $ \(exp,args) s ->
@@ -282,7 +283,7 @@
                              Just e -> " [<a href='?exp="++quote (show e)++"'>"
                                     ++ "expand definition</a>]"
                              Nothing -> ""
-                     in (let ?state=s in renderExp exp id ++ lnk ++ "<hr>\n"
+                     in (let ?state=s; ?link=True in renderExp exp id ++ lnk ++ "<hr>\n"
                            ++ if (isComplete exp)
                                 then (head $ evalStateT (runExp env exp) s)
                                 else "(Incomplete expression.)", s)
@@ -291,7 +292,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 id ++ "<hr>\n" ++ r, s')
+                     in (let ?state=s; ?link=True in renderExp exp id ++ "<hr>\n" ++ r, s')
                , h (Prefix ["edit"]) GET $ ok $ \() -> run edit
 
                , h () GET  $ ok $ \() () -> view