[Fencommits] fenserve: broken code for editing existing potion definitions

[Benja Fallenstein]

Thu May 24 17:30:25 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * broken code for editing existing potion definitions
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-05-24 17:30:33.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-05-24 17:30:33.000000000 +0300
@@ -250,15 +250,16 @@
 instance FromMessage String where
     fromMessageM m = lookM m "name" 
 
-instance FromMessage (Exp, [Value]) where
+instance FromMessage (Exp, [Value], Maybe String) where
     fromMessageM m = do let n = maybe 0 read (lookM m "count")
                         vals <- forM [1..n] $ \i -> lookM m ("arg" ++ show i)
                         exp <- lookM m "exp"
-                        return (read exp, vals)
+                        return (read exp, vals, lookM m "name")
 
-instance FromMessage [Value] where
+instance FromMessage ([Value], Maybe String) where
     fromMessageM m = do let n = maybe 0 read (lookM m "count")
-                        forM [1..n] $ \i -> lookM m ("arg" ++ show i)
+                        vals <- forM [1..n] $ \i -> lookM m ("arg" ++ show i)
+                        return (vals, lookM m "name")
 
 instance FromMessage (Exp, Exp, Type) where
     fromMessageM m = do exp <- lookM m "exp"
@@ -283,8 +284,8 @@
     s { stateSchema = Map.insert (toLower c : cs) [] $ stateSchema s})
 
 expand s (Call n args) = case readFun s n of 
-    Fun _ _ body -> Just $
-        foldr (\i e -> subst' i (args !! i) e) body [0..length args-1]
+    Fun _ _ body -> Just 
+        (foldr (\i e -> subst' i (args !! i) e) body [0..length args-1], n)
     _ -> Nothing
 expand _ _ = Nothing
 
@@ -314,7 +315,7 @@
         Right (s, state') -> do put state'; respond (s, html $ link s "link")
         Left e -> respond $ ("", "Internal server error: " ++ show e)
 
-potionGet exp args s = (let ?state=s; ?link=True in 
+potionGet exp args name s = (let ?state=s; ?link=True in 
                         renderExp exp id string +++ " " +++ lnk +++ hr
                     +++ if (isComplete exp)
                         then (HTML $ head $ evalStateT (runExp env exp) s)
@@ -322,8 +323,12 @@
                        , s) where
     env = Map.fromList $ zip [0..length args-1] args
     lnk = case expand s exp of
-              Just e -> link ("?exp="++show e) "[expand definition]"
-              Nothing -> link ("makefun?exp="++show exp) "[save]"
+              Just (e,n) -> link ("?exp="++show e++"&name="++n) "[expand definition]"
+              Nothing -> formP "addpotion" $ (+++hidden "exp" (show exp)) $
+                         (+++link ("makefun?exp="++show exp) "[Save as...]") $
+                         flip (maybe $ HTML "") name $ \name' ->
+                             hidden "template" name' +++
+                             button ("[Save as "++name'++"]")+++" "+++mdot+++" "
 
 potionPost exp args s = (let ?state=s; ?link=True in 
                          renderExp exp id action +++ hr +++ HTML r
@@ -471,13 +476,13 @@
 
 main = stdHTTP [ debugFilter
                , h ["potion"] GET $ ok $ \() -> run $ 
-                   \(exp,args) s -> potionGet exp args s
+                   \(exp,args,name) s -> potionGet exp args name s
                , h ["potion"] POST $ ok $ \() -> run $ 
-                   \(exp,args) s -> potionPost exp args s
+                   \(exp,args,name::Maybe String) s -> potionPost exp args s
                , h (Prefix ["potion"]) GET $ ok $ \[fun] -> run $ 
-                   \(args) s -> potionGet (Call fun (map (Just . Str) args)) args s
+                   \(args,name) s -> potionGet (Call fun (map (Just . Str) args)) args name s
                , h (Prefix ["potion"]) POST $ ok $ \[fun] -> run $ 
-                   \(args) s -> potionPost (Call fun (map (Just . Str) args)) args s
+                   \(args,name::Maybe String) s -> potionPost (Call fun (map (Just . Str) args)) args s
                , h ["edit"] GET $ ok $ \() -> run edit
                , h ["editTemplate"] GET $ seeOther $ \() -> runRedirect editTemplate
                , h ["makefun"] GET $ ok $ \() -> run makeFun