[Fencommits] fenserve: unbreak it
Benja Fallenstein
benja.fallenstein at gmail.com
Thu May 24 17:52:20 EEST 2007
Thu May 24 17:52:14 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* unbreak it
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-24 17:52:20.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-24 17:52:20.000000000 +0300
@@ -98,16 +98,18 @@
expType (Concat _) = string
expType (Str _) = string
-editLink :: (?link :: Bool, ToHTML a) => (Exp -> Exp) -> Exp -> Type -> a -> HTML
+editLink :: (?link :: Bool, ?name :: Maybe String, ToHTML a) =>
+ (Exp -> Exp) -> Exp -> Type -> a -> HTML
editLink f old t s | not ?link = toHTML s | otherwise =
flip (tag "a") s [("class", "editLink"), ("href",
- "edit?exp="++(show $ f $ Var (-1))++"&old="++show old++"&type="++show t)]
+ "edit?exp="++(show $ f $ Var (-1))++"&old="++show old++"&type="++show t
+ ++maybe "" ("&name="++) ?name)]
renderMaybeExp (Just exp) cx ty = renderExp' exp cx ty
renderMaybeExp Nothing cx ty = editLink cx (Var 0) ty $ surround $ bold $
"[" +++ typeQuestion ty +++ "]"
-renderExp :: (?state :: MyState, ?link :: Bool) => Exp -> (Exp -> Exp) -> Type -> HTML
+renderExp :: (?state :: MyState, ?link :: Bool, ?name :: Maybe String) => Exp -> (Exp -> Exp) -> Type -> HTML
renderExp exp@(Call fname args) cx ty = 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
@@ -241,7 +243,7 @@
-}
respond $ html $ header +++ (catFor (getPotions state) $ \exp ->
para $ link ("potion?exp="++(escape $ show exp)) $
- let ?state = state; ?link=False in renderExp' exp id string)
+ let ?state = state; ?link=False; ?name=Nothing in renderExp' exp id string)
instance FromMessage (String,String) where
fromMessageM m = do cat <- lookM m "category"; name <- lookM m "name"
@@ -261,11 +263,11 @@
vals <- forM [1..n] $ \i -> lookM m ("arg" ++ show i)
return (vals, lookM m "name")
-instance FromMessage (Exp, Exp, Type) where
+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)
+ return (read exp, read old, read ty, lookM m "name")
addField req state = (returnTo,state') where
state' = state { stateSchema = Map.insert cat (fs ++ [name]) (stateSchema state),
@@ -315,7 +317,7 @@
Right (s, state') -> do put state'; respond (s, html $ link s "link")
Left e -> respond $ ("", "Internal server error: " ++ show e)
-potionGet exp args name s = (let ?state=s; ?link=True in
+potionGet exp args name s = (let ?state=s; ?link=True; ?name=name in
renderExp exp id string +++ " " +++ lnk +++ hr
+++ if (isComplete exp)
then (HTML $ head $ evalStateT (runExp env exp) s)
@@ -327,10 +329,10 @@
Nothing -> formP "addpotion" $ (+++hidden "exp" (show exp)) $
(+++link ("makefun?exp="++show exp) "[Save as...]") $
flip (maybe $ HTML "") name $ \name' ->
- hidden "template" name' +++
+ hidden "name" name' +++
button ("[Save as "++name'++"]")+++" "+++mdot+++" "
-potionPost exp args s = (let ?state=s; ?link=True in
+potionPost exp args s = (let ?state=s; ?link=True; ?name=Nothing in
renderExp exp id action +++ hr +++ HTML r
, s') where
env = Map.fromList $ zip [0..length args-1] args
@@ -338,16 +340,17 @@
[result] -> result
xs -> ("Wrong number of results: "++show xs, s)
-edit :: (Exp,Exp,Type) -> MyState -> (HTML, MyState)
-edit (exp,old@(Concat olds),ty) s = let ?state = s; ?link = False in
+edit :: (Exp,Exp,Type,Maybe String) -> MyState -> (HTML, MyState)
+edit (exp,old@(Concat olds),ty,name) s = let ?state = s; ?link = False; ?name=name in
(formG "editTemplate" $
para (textarea "template" 20 80 $ f 1 olds)
+++ para (submit "Submit" +++ hidden "exp" (show exp)
+ +++ maybe (HTML "") (hidden "name") name
+++ hidden "old" (show old)), s) where
f i (Just (Str s) : xs) = s +++ f i xs
f i (_:xs) = "$" +++ show i +++ f (i+1) xs
f _ [] = toHTML ""
-edit (exp,old,ty) s = let ?state = s; ?link = False in
+edit (exp,old,ty,name) s = let ?state = s; ?link = False; ?name=name in
(para ("Select something to replace '" +++ renderExp' old id ty +++ "' "
+++ "with.") +++ hr
+++ para ("Variables: " +++ cat [linkExp (Var i) (renderVar i)+++" "
@@ -355,11 +358,12 @@
+++ (catFor (filter ((==ty) . expType) $ getPotions s) $ \repl ->
para $ li $ linkExp repl $ renderExp repl id (error "some type"))
, s) where linkExp new = tag "a" [("class", "editLink"),
- ("href", "potion?exp=" ++ show (subst (-1) new exp))] .
+ ("href", "potion?exp=" ++ show (subst (-1) new exp)
+ ++ maybe "" ("&name="++) name)] .
tag "span" [("class", "editPotion")]
makeFun :: Request -> MyState -> (HTML, MyState)
-makeFun msg s = let ?state = s; ?link = False in
+makeFun msg s = let ?state = s; ?link = False; ?name=lookM msg "name" in
(para ("Save '"+++renderExp' exp id (error "some type")+++"' as the "
+++ "following potion (" +++ code "$(cat)" +++ ", where 'cat' is \
\a category name, marks a hole):")
@@ -370,6 +374,7 @@
editTemplate :: Request -> MyState -> (String, MyState)
editTemplate msg s =
("/potion?exp=" ++ concatMap escapeMore (escape (show (subst (-1) new exp)))
+ ++ maybe "" ("&name="++) (lookM msg "name")
, s) where
escapeMore '[' = "%5b"; escapeMore ']' = "%5d"; escapeMore c = [c]
Just exp = fmap read $ lookM msg "exp"
@@ -388,13 +393,16 @@
addPotion msg s = ("/", s { statePotions = newPotions }) where
Just template = lookM msg "template"
Just exp = fmap read $ lookM msg "exp"
- name = getName template where
+ name = fromMaybe (getName template) $ lookM msg "name" where
getName ('$':'(':cs) = 'X' : getName (drop 1 $ dropWhile (/= ')') cs)
getName (' ':cs) = '_' : getName cs
getName (c:cs) = c : getName cs
getName "" = ""
- (parts, types) = f template ""
- potion = Fun types (map toHTML parts) exp
+ potion = case lookM msg "name" of
+ Nothing -> let (parts, types) = f template ""
+ in Fun types (map toHTML parts) exp
+ Just n -> let Fun ts ps _ = statePotions s Map.! n
+ in Fun ts ps exp
newPotions = Map.insert name potion $ statePotions s
f ('$':'(':cs) part = (reverse part : ps, t : ts)
where (ps,ts) = f (drop 1 $ dropWhile (/= ')') cs) ""
More information about the Fencommits
mailing list