[Fencommits] fenserve: HTML can be edited with holes now
Benja Fallenstein
benja.fallenstein at gmail.com
Mon May 21 15:20:25 EEST 2007
Mon May 21 15:16:23 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* HTML can be edited with holes now
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-21 15:20:23.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-21 15:20:23.000000000 +0300
@@ -71,7 +71,7 @@
data Exp = Call String [Maybe Exp]
| Var Int
| Forall Int Exp Exp
- | HTML [Exp]
+ | HTML [Maybe Exp]
| Str String
deriving (Read, Show, Typeable, Data)
@@ -86,6 +86,11 @@
"<a href='edit?exp=" ++ quote (show $ f $ Var (-1))
++ "&old=" ++ quote (show old)
++ "&type=" ++ quote (show t) ++ "'>" ++ s ++ "</a>"
+
+renderMaybeExp (Just exp) cx ty = renderExp' exp cx ty
+renderMaybeExp Nothing cx ty = editLink cx (Var 0) ty $ surround
+ $ "<b style='color: maroon'>[" ++ typeQuestion ty
+ ++ "]</b>"
renderExp :: (?state :: MyState, ?link :: Bool) => Exp -> (Exp -> Exp) -> Type -> String
renderExp exp@(Call fname args) cx ty = f (funTypes fun) (funParts fun) args 0 where
@@ -93,20 +98,21 @@
cx' n e = cx $ Call fname $ take n args ++ [Just e] ++ drop (n+1) args
f [] [x] _ n = editLink cx exp ty x
f (t:ts) (x:xs) (y:ys) n =
- editLink cx exp ty x ++ maybe (editLink (cx' n) (Var 0) t $ surround $ "<b style='color: maroon'>[" ++ typeQuestion t ++ "]</b>") (\exp' -> renderExp' exp' (cx' n) t) y ++ f ts xs ys (n+1)
+ editLink cx exp ty x ++ renderMaybeExp y (cx' n) t ++ f ts xs ys (n+1)
renderExp exp@(Var i) cx ty = editLink cx exp ty (renderVar i)
renderExp (Forall i exp body) cx _ = "For each of " ++ renderExp' exp (\e -> cx $ Forall i e body) (expType exp)
++ " (call it '" ++ renderVar i ++ "'):\n"
++ "<blockquote>\n" ++ renderExp body (\e -> cx $ Forall i exp e) string
++ "</blockquote>"
renderExp (Str s) cx _ = "<small>" ++ quoteP s ++ "</small>"
-renderExp exp@(HTML exps) cx _ = "<p>" ++ concatMap (\i -> renderExp' (exps!!i) (\e -> cx $ HTML $ take i exps ++ [e] ++ drop (i+1) exps) string) [0..length exps-1] ++ if ?link then "<p>" ++ editLink cx exp string "[edit]" else ""
+renderExp exp@(HTML exps) cx _ = "<p>" ++ concatMap (\(xs,x,xs') -> renderMaybeExp x (\e -> cx (HTML (xs ++ [Just e] ++ xs'))) string) (slices exps) ++ if ?link then "<p>" ++ editLink cx exp string "[edit]" else ""
renderExp' e@(Str _) cx ty = renderExp e cx ty
renderExp' e cx ty = surround (renderExp e cx ty)
surround s = "<span style='border: dashed black 1px; padding: 2px; margin: 2px; line-height: 90%;'>" ++ s ++ "</span>"
+slices xs = map (\i -> (take i xs, xs !! i, drop (i+1) xs)) [0..length xs-1]
quote = concatMap quoteChar
quoteBr = concatMap (\c -> case c of '\n' -> "<br>"; _ -> quoteChar c)
@@ -121,7 +127,7 @@
isComplete (Call _ args) = all (maybe False isComplete) args
isComplete (Forall _ exp body) = isComplete exp && isComplete body
isComplete (Var _) = True
-isComplete (HTML exps) = all isComplete exps
+isComplete (HTML exps) = all (maybe False isComplete) exps
isComplete (Str _) = True
type Env = Map Int Value
@@ -138,7 +144,7 @@
runExp (Map.insert v x env) body
return $ concat rs
runExp env (Var i) = return $ env Map.! i
-runExp env (HTML exps) = do rs <- mapM (runExp env) exps
+runExp env (HTML exps) = do rs <- mapM (\(Just e) -> runExp env e) exps
return $ concat rs
runExp _ (Str s) = return s
@@ -190,21 +196,21 @@
])
potion = Forall 0 (Call (show $ CatFun "post") []) $
- HTML [Str "<h2>", Call (show $ FieldFun "post" "title") v, Str "</h2>\n",
- Str "<p>Author: ", Call (show $ FieldFun "post" "author") v,
- Str "<p>", Call (show $ FieldFun "post" "body") v,
- Str "<hr>"]
+ HTML (map Just [Str "<h2>", Call (show $ FieldFun "post" "title") v, Str "</h2>",
+ Str "\n<p>Author: ", Call (show $ FieldFun "post" "author") v,
+ Str "\n<p>", Call (show $ FieldFun "post" "body") v,
+ Str "\n<hr>"])
where v = [Just $ Var 0]
-addPostForm = HTML [Str "<h2>Add entry</h2>\n\
- \<form action=/potion/addPost method=post>\n\
- \<input type=hidden name=count value=3>\n\
- \Title: <input name=arg1><br>\n\
- \Author: <input name=arg2><br>\n\
- \Body:<br><textarea name=arg3></textarea>\n\
- \<input type=submit>\n\
- \</form>"
- ]
+addPostForm = HTML $ map Just [Str "<h2>Add entry</h2>\n\
+ \<form action=/potion/addPost method=post>\n\
+ \<input type=hidden name=count value=3>\n\
+ \Title: <input name=arg1><br>\n\
+ \Author: <input name=arg2><br>\n\
+ \Body:<br><textarea name=arg3></textarea>\n\
+ \<input type=submit>\n\
+ \</form>"
+ ]
addPost =
Call (show $ AddItemFun "post" ["title","author","body"]) [Just (Var i) | i <- [0..2]]
@@ -227,7 +233,8 @@
++ concatMap category (Map.toList $ stateSchema state)
-}
respond $ header ++ (concatFor (getPotions state) $ \exp ->
- "<p>" ++ let ?state = state; ?link=True in renderExp exp id string ++ "\n")
+ "<p><a href='potion?exp=" ++ (quote $ escape $ show exp) ++ "'>"
+ ++ let ?state = state; ?link=False in renderExp' exp id string ++ "</a>\n")
instance FromMessage (String,String) where
fromMessageM m = do cat <- lookM m "category"; name <- lookM m "name"
@@ -325,7 +332,7 @@
\ <p><input type='submit' value='Submit'>\
\ <input type='hidden' name='exp' value='"++show exp++"'>\
\ <input type='hidden' name='old' value='"++show old++"'>\
- \</form>", s) where f i (Str s : xs) = s ++ f i xs
+ \</form>", s) where f i (Just (Str s) : xs) = s ++ f i xs
f i (_:xs) = "$" ++ show i ++ f (i+1) xs
f _ [] = ""
edit (exp,old,ty) s = let ?state = s; ?link = False in
@@ -356,15 +363,14 @@
Just exp = fmap read $ lookM msg "exp"
Just (HTML olds) = fmap read $ lookM msg "old"
Just tmp = lookM msg "template"
- exps = filter (\e -> case e of Str _ -> False; _ -> True) olds
+ exps = filter (\e -> case e of Just (Str _) -> False; _ -> True) olds
new = HTML $ f tmp
f ('$':c:cs)
- | i < length exps = Str "" : (exps !! i) : f cs
- | otherwise = Str "" : Var 0 : f cs
+ | i < length exps = Just (Str "") : (exps !! i) : f cs
+ | otherwise = Just (Str "") : Nothing : f cs
where i = read [c] - 1
- f ('$':cs) = Str "" : (Var 0) : f cs
- f (c:cs) = (Str (c:r):rs) where (Str r:rs) = f cs
- f "" = [Str ""]
+ f (c:cs) = (Just (Str (c:r)):rs) where (Just (Str r):rs) = f cs
+ f "" = [Just (Str "")]
addPotion :: Request -> MyState -> (String, MyState)
addPotion msg s = ("/", s { statePotions = newPotions }) where
More information about the Fencommits
mailing list