[Fencommits] fenserve: fixed bugs, added css, types, template editing
Tuukka Hastrup
Tuukka.Hastrup at iki.fi
Sun May 20 21:02:00 EEST 2007
Sun May 20 20:59:09 EEST 2007 Tuukka Hastrup <Tuukka.Hastrup at iki.fi>
* fixed bugs, added css, types, template editing
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-20 21:02:00.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-20 21:02:00.000000000 +0300
@@ -13,17 +13,19 @@
import qualified System.IO.Unsafe
import qualified Control.Exception
+header = "<head><style>a { text-decoration: none; color: inherit; }</style></head>"
+
type Id = Int
data Item = Item { itemFields :: Map String String, itemCategories :: Set String }
deriving (Read, Show, Typeable, Data)
data Type = Type { typeQuestion :: String }
- deriving (Read, Show, Typeable, Data)
+ deriving (Read, Show, Typeable, Data, Eq)
catType name = Type ("which " ++ name ++ "?")
-fieldType name = Type ("which " ++ name ++ "?")
string = Type "which text?"
+action = Type "Do what?"
data Fun = Fun [Type] [String] Exp
| FieldFun String String
@@ -35,13 +37,22 @@
readFun s n | ((r,""):_) <- reads n = r
| otherwise = statePotions s Map.! n
+funType (Fun _ _ exp) = expType exp
+funType (FieldFun _ _) = string
+funType (CatFun cat) = catType cat
+funType (AddItemFun _ _) = action
+
funTypes (Fun ts _ _) = ts
funTypes (FieldFun cat _) = [catType cat]
funTypes (CatFun _) = []
+funTypes (AddItemFun _ fs) = map (const string) fs
funParts (Fun _ ps _) = ps
funParts (FieldFun _ name) = ["the "++name++" of ", ""]
funParts (CatFun cat) = [cat]
+funParts (AddItemFun cat fs) = ["Add a new "++cat++" with "] ++
+ [" as the "++f++", and " | f <- init fs] ++
+ [" as the "++last fs++"."]
for :: [a] -> (a -> b) -> [b]
for = flip map
@@ -63,30 +74,37 @@
| Str String
deriving (Read, Show, Typeable, Data)
-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))
- ++ "&old=" ++ quote (show old) ++ "'>" ++ s ++ "</a>"
+expType (Call fun _) = funType $ readFun ?state fun
+expType (Var _) = error "no type inference yet"
+expType (Forall _ _ _) = string
+expType (HTML _) = string
+expType (Str _) = string
+
+editLink :: (?link :: Bool) => (Exp -> Exp) -> Exp -> Type -> String -> String
+editLink f old t s | not ?link = s | otherwise =
+ "<a href='edit?exp=" ++ quote (show $ f $ Var (-1))
+ ++ "&old=" ++ quote (show old)
+ ++ "&type=" ++ quote (show t) ++ "'>" ++ s ++ "</a>"
-renderExp :: (?state :: MyState, ?link :: Bool) => Exp -> (Exp -> Exp) -> String
-renderExp exp@(Call fname args) cx = f (funTypes fun) (funParts fun) args 0 where
+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
fun = readFun ?state fname
cx' n e = cx $ Call fname $ take n args ++ [Just e] ++ drop (n+1) args
- f [] [x] _ n = editLink cx exp x
+ f [] [x] _ n = editLink cx exp ty x
f (t:ts) (x:xs) (y:ys) n =
- 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)
+ 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)
+renderExp exp@(Var i) cx ty = editLink cx exp ty (renderVar i)
+renderExp (Forall i exp body) cx _ = "For each " ++ renderExp' exp (\e -> cx $ Forall i e body) (expType exp)
++ " " ++ renderVar i ++ ":\n"
- ++ "<blockquote>\n" ++ renderExp body (\e -> cx $ Forall i exp e)
+ ++ "<blockquote>\n" ++ renderExp body (\e -> cx $ Forall i exp e) string
++ "</blockquote>"
-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 (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' e@(Str _) cx = renderExp e cx
-renderExp' e cx = surround (renderExp e cx)
+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'>" ++ s ++ "</span>"
+surround s = "<span style='border: dashed black 1px; padding: 2px; margin: 2px; line-height: 90%;'>" ++ s ++ "</span>"
quote = concatMap quoteChar
@@ -207,8 +225,8 @@
++ "</form>"
++ concatMap category (Map.toList $ stateSchema state)
-}
- respond $ concatFor (getPotions state) $ \exp ->
- "<p>" ++ let ?state = state; ?link=False in renderExp exp id ++ "\n"
+ respond $ header ++ (concatFor (getPotions state) $ \exp ->
+ "<p>" ++ let ?state = state; ?link=True in renderExp exp id string ++ "\n")
instance FromMessage (String,String) where
fromMessageM m = do cat <- lookM m "category"; name <- lookM m "name"
@@ -223,10 +241,11 @@
exp <- lookM m "exp"
return (read exp, vals)
-instance FromMessage (Exp, Exp) where
+instance FromMessage (Exp, Exp, Type) where
fromMessageM m = do exp <- lookM m "exp"
old <- lookM m "old"
- return (read exp, read old)
+ ty <- lookM m "type"
+ return (read exp, read old, read ty)
addField cat name = do
state <- get
@@ -262,20 +281,54 @@
run f x = do
state <- get; let r = f x state
case System.IO.Unsafe.unsafePerformIO $ Control.Exception.catch (Control.Exception.evaluate (length (show r) `seq` Right r)) (\e -> return $ Left e) of
- Right (s, state') -> do put state'; respond s
+ Right (s, state') -> do put state'; respond $ header ++ s
Left e -> respond $ "Internal server error: " ++ show e
-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) ++ " "
+runRedirect f x = do
+ state <- get; let r = f x state
+ case System.IO.Unsafe.unsafePerformIO $ Control.Exception.catch (Control.Exception.evaluate (length (show r) `seq` Right r)) (\e -> return $ Left e) of
+ Right (s, state') -> do put state'; respond (s, "<a href='"++quote s++"'>link</a>")
+ Left e -> respond $ ("", "Internal server error: " ++ show e)
+
+edit :: (Exp,Exp,Type) -> MyState -> (String, MyState)
+edit (exp,old@(HTML olds),ty) s = let ?state = s; ?link = False in
+ ("<form action='editTemplate' method='get'>\
+ \ <p><textarea name='template' rows='20' cols='80'>" ++ f 1 olds ++
+ " </textarea>\
+ \ <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
+ f i (_:xs) = "$" ++ show i ++ f (i+1) xs
+ f _ [] = ""
+edit (exp,old,ty) s = let ?state = s; ?link = False in
+ ("<p>Select something to replace '" ++ renderExp' old id ty ++ "' with.\n<hr>\n" ++
+ ("<p>Variables: " ++ concat [link (Var i) (surround $ renderVar i) ++ " "
| i <- [0..25]]) ++
- (concatFor (getPotions s) $ \repl ->
- "<p><li>" ++ (link repl $ let ?state = s; ?link=False
- in renderExp repl id) ++ "\n")
+ (concatFor (filter ((==ty) . expType) $ getPotions s) $ \repl ->
+ "<p><li>" ++ (link repl $ renderExp' repl id (error "some type")) ++ "\n")
, s) where link new s = "<a href='potion?exp=" ++ show (subst (-1) new exp)
++ "'>" ++ s ++ "</a>"
+editTemplate :: Request -> MyState -> (String, MyState)
+editTemplate msg s =
+ ("/potion?exp=" ++ concatMap escapeMore (escape (show (subst (-1) new exp)))
+ , s) where
+ escapeMore '[' = "%5b"; escapeMore ']' = "%5d"; escapeMore c = [c]
+ 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
+ new = HTML $ f tmp
+ f ('$':c:cs)
+ | i < length exps = Str "" : (exps !! i) : f cs
+ | otherwise = Str "" : Var 0 : 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 ""]
+
+
main = stdHTTP [ debugFilter
, h (Prefix ["potion"]) GET $ ok $ \() -> run $ \(exp,args) s ->
let env = Map.fromList $ zip [0..length args-1] args
@@ -283,7 +336,7 @@
Just e -> " [<a href='?exp="++quote (show e)++"'>"
++ "expand definition</a>]"
Nothing -> ""
- in (let ?state=s; ?link=True in renderExp exp id ++ lnk ++ "<hr>\n"
+ in (let ?state=s; ?link=True in renderExp exp id string ++ lnk ++ "<hr>\n"
++ if (isComplete exp)
then (head $ evalStateT (runExp env exp) s)
else "(Incomplete expression.)", s)
@@ -292,8 +345,9 @@
(r,s') = case runStateT (runExp env exp) s of
[result] -> result
xs -> ("Wrong number of results: "++show xs, s)
- in (let ?state=s; ?link=True in renderExp exp id ++ "<hr>\n" ++ r, s')
+ in (let ?state=s; ?link=True in renderExp exp id action ++ "<hr>\n" ++ r, s')
, h (Prefix ["edit"]) GET $ ok $ \() -> run edit
+ , h ["editTemplate"] GET $ seeOther $ \() -> runRedirect editTemplate
, h () GET $ ok $ \() () -> view
, h ["addfield"] POST $ ok $ \() (cid,name) -> addField cid name
More information about the Fencommits
mailing list