[Fencommits] fenserve: remove FromMessage instances

[Benja Fallenstein]

Fri May 25 17:29:26 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * remove FromMessage instances
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs	2007-05-25 17:29:35.000000000 +0300
+++ new-fenserve/fendata/Main.hs	2007-05-25 17:29:35.000000000 +0300
@@ -48,29 +48,11 @@
                     Str "\n<hr>"])
     where v = [Just $ Var 0]
 
-instance FromMessage (String,String) where
-    fromMessageM m = do cat <- lookM m "category"; name <- lookM m "name" 
-                        return (cat, name)
-
-instance FromMessage String where
-    fromMessageM m = lookM m "name" 
-
-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, lookM m "name")
-
-instance FromMessage ([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)
-                        return (vals, lookM m "name")
-
-instance FromMessage (Exp, Exp, Type, Maybe String) where
-    fromMessageM m = do exp <- lookM m "exp"
-                        old <- lookM m "old"
-                        ty <- lookM m "type"
-                        return (read exp, read old, read ty, lookM m "name")
+readArgs :: Request -> [Value]
+readArgs req = fromMaybe [] $ do
+    n <- fmap read $ lookM req "count"
+    forM [1..n] $ \i -> lookM req ("arg" ++ show i)
+
 
 addField req state = (returnTo,state') where
     state' = state { stateSchema = Map.insert cat (fs ++ [name]) (stateSchema state),
@@ -85,8 +67,9 @@
     Just name = lookM req "field" 
     returnTo = fromMaybe ("item/"++item) (lookM req "returnTo")
 
-addCategory name s = ("table",
-    s { stateSchema = Map.insert (uncapitalize name) [] $ stateSchema s})
+addCategory req s = ("table",
+    s { stateSchema = Map.insert (uncapitalize name) [] $ stateSchema s}) where
+    Just name = lookM req "name"
 
 expand s (Call n args) = case readFun s n of 
     Fun _ _ body -> Just 
@@ -281,10 +264,14 @@
     
 main = stdHTTP [ debugFilter
                , h ["potion"] GET $ ok $ \() -> run $ 
-                   \(exp,args,name) s -> let ?root = "" in potionGet exp args name s
+                   \req s -> let ?root = "" in potionGet (read $ fromJust $ lookM req "exp") (readArgs req) (lookM req "name") s
                , h (Prefix ["potion"]) GET $ ok $ \(fun:args) -> run $ 
-                   \(_::[String],name) s -> let ?root = concat (take (1 + length args) $ repeat "../") in potionGet (Call fun (map (Just . Str) args)) args name s
-               , h ["edit"] GET $ ok $ \() -> run edit
+                   \req s -> let ?root = concat (take (1 + length args) $ repeat "../") in potionGet (Call fun (map (Just . Str) $ readArgs req)) (readArgs req) (lookM req "name") s
+               , h ["edit"] GET $ ok $ \() -> run $ \req ->
+                     edit (read $ fromJust $ lookM req "exp",
+                           read $ fromJust $ lookM req "old",
+                           read $ fromJust $ lookM req "type",
+                           lookM req "name")
                , h ["editTemplate"] GET $ seeOther $ \() -> runRedirect editTemplate
                , h ["makefun"] GET $ ok $ \() -> run makeFun
                , h ["table"] GET $ ok $ \() -> run showTable