[Fencommits] fenserve: some more progress
Benja Fallenstein
benja.fallenstein at gmail.com
Tue May 15 23:14:39 EEST 2007
Tue May 15 23:14:19 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* some more progress
diff -rN -u old-fenserve-1/fendata/Main.hs new-fenserve-1/fendata/Main.hs
--- old-fenserve-1/fendata/Main.hs 2007-05-15 23:14:39.000000000 +0300
+++ new-fenserve-1/fendata/Main.hs 2007-05-15 23:14:39.000000000 +0300
@@ -22,7 +22,8 @@
deriving (Read, Show, Typeable, Data)
catType name = Type ("which " ++ name ++ "?")
-string = Type "which string?"
+fieldType name = Type ("which " ++ name ++ "?")
+string = Type "which text?"
data Fun = Fun [Type] [String] Exp
| FieldFun String String
@@ -40,7 +41,20 @@
funParts (Fun _ ps _) = ps
funParts (FieldFun _ name) = ["the "++name++" of ", ""]
-funParts (CatFun cat) = ["all " ++ cat ++ "s"]
+funParts (CatFun cat) = [cat]
+
+for :: [a] -> (a -> b) -> [b]
+for = flip map
+
+concatFor :: [a] -> (a -> [b]) -> [b]
+concatFor = flip concatMap
+
+getPotions :: MyState -> [Exp]
+getPotions s = map f (Map.toList $ statePotions s)
+ ++ concatFor (Map.toList $ stateSchema s) (\(cat,fs) ->
+ Call (show $ CatFun cat) []
+ : map (\f -> Call (show $ FieldFun cat f) [Nothing]) fs) where
+ f (n, Fun ts _ _) = Call n (replicate (length ts) Nothing)
data Exp = Call String [Maybe Exp]
| Var Int
@@ -54,9 +68,9 @@
fun = readFun ?state fname
f [] [x] _ = x
f (t:ts) (x:xs) (y:ys) =
- x ++ maybe ("[" ++ typeQuestion t ++ "]") renderExp' y ++ f ts xs ys
+ x ++ maybe (surround $ "<b style='color: maroon'>[" ++ typeQuestion t ++ "]</b>") renderExp' y ++ f ts xs ys
renderExp (Var i) = renderVar i
-renderExp (Forall i exp body) = "For " ++ renderExp' exp
+renderExp (Forall i exp body) = "For each " ++ renderExp' exp
++ " " ++ renderVar i ++ ":\n"
++ "<blockquote>\n" ++ renderExp body
++ "</blockquote>"
@@ -64,7 +78,9 @@
renderExp (HTML exps) = concatMap (\e -> "<p>" ++ renderExp' e ++ "\n") exps
renderExp' e@(Str _) = renderExp e
-renderExp' e = "<span style='border: dashed black 1px; padding: 2px; margin: 2px'>" ++ renderExp e ++ "</span>"
+renderExp' e = surround (renderExp e)
+
+surround s = "<span style='border: dashed black 1px; padding: 2px; margin: 2px'>" ++ s ++ "</span>"
quote "" = ""
@@ -145,7 +161,7 @@
(Map.fromList [
("list", Fun [] ["A list of all posts"] potion)
, ("addPostForm", Fun [] ["Form for adding posts"] addPostForm)
- , ("addPost", Fun [string,string,string] ["Add a new post with title ", ", author ", ", and body ", "."] addPost)
+ , ("addPost", Fun [string,string,string] ["Add a new post with ", " as the title, ", " as the author, and ", " as the body."] addPost)
])
potion = Forall 0 (Call (show $ CatFun "post") []) $
@@ -169,6 +185,7 @@
view = do
(state :: MyState) <- get
+ {-
let category (name,fields) = "<h3>" ++ name ++ "</h3>\n"
++ concatMap field fields
++ "<p>Add field: "
@@ -183,6 +200,9 @@
++ "<input type=text name=name>"
++ "</form>"
++ concatMap category (Map.toList $ stateSchema state)
+ -}
+ respond $ concatFor (getPotions state) $ \exp ->
+ "<p>" ++ let ?state = state in renderExp exp ++ "\n"
instance FromMessage (String,String) where
fromMessageM m = do cat <- lookM m "category"; name <- lookM m "name"
@@ -197,6 +217,11 @@
exp <- lookM m "exp"
return (read exp, vals)
+instance FromMessage (Exp, Exp) where
+ fromMessageM m = do exp <- lookM m "exp"
+ old <- lookM m "old"
+ return (read exp, read old)
+
addField cat name = do
state <- get
let fs = stateSchema state Map.! cat
@@ -208,17 +233,25 @@
put $ state { stateSchema = Map.insert cat [] $ stateSchema state}
view
-expand s (Call n args) = Just result where
- Fun _ _ body = readFun s n
- result = foldr (\i e -> subst i (args !! i) e) body [0..length args-1]
+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]
+ _ -> Nothing
expand _ _ = Nothing
-subst :: Int -> Maybe Exp -> Exp -> Exp
-subst i repl e = everywhere (mkT f) e where
+subst :: Int -> Exp -> Exp -> Exp
+subst i repl e = everywhere (mkT f) e where
+ f :: Exp -> Exp
+ f (Var j) | j == i = repl
+ f x = x
+
+subst' :: Int -> Maybe Exp -> Exp -> Exp
+subst' i repl e = everywhere (mkT f) e where
f :: Maybe Exp -> Maybe Exp
f (Just (Var j)) | j == i = repl
f x = x
+
--run :: (a -> MyState -> (String, MyState)) -> a -> blah
run f x = do
state <- get; let r = f x state
@@ -226,6 +259,14 @@
Right (s, state') -> do put state'; respond 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" ++
+ (concatFor (getPotions s) $ \repl ->
+ "<p><li><a href='potion?exp=" ++ show (subst (-1) repl exp) ++
+ "'>" ++ let ?state = s in renderExp repl ++ "</a>\n")
+ , s)
+
main = stdHTTP [ debugFilter
, h (Prefix ["potion"]) GET $ ok $ \() -> run $ \(exp,args) s ->
let env = Map.fromList $ zip [0..length args-1] args
@@ -234,13 +275,16 @@
++ "expand definition</a>]"
Nothing -> ""
in (let ?state=s in renderExp exp ++ lnk ++ "<hr>\n"
- ++ (head $ evalStateT (runExp env exp) s), s)
+ ++ if (isComplete exp)
+ then (head $ evalStateT (runExp env exp) s)
+ else "(Incomplete expression.)", s)
, h (Prefix ["potion"]) POST $ ok $ \() -> run $ \(exp,args) s ->
let env = Map.fromList $ zip [0..length args-1] args
(r,s') = case runStateT (runExp env exp) s of
[result] -> result
xs -> ("Wrong number of results: "++show xs, s)
in (let ?state=s in renderExp exp ++ "<hr>\n" ++ r, s')
+ , h (Prefix ["edit"]) GET $ ok $ \() -> run edit
, h () GET $ ok $ \() () -> view
, h ["addfield"] POST $ ok $ \() (cid,name) -> addField cid name
More information about the Fencommits
mailing list