[Fencommits] fenserve: more progress
Benja Fallenstein
benja.fallenstein at gmail.com
Tue May 15 21:34:24 EEST 2007
Tue May 15 21:34:06 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* more progress
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-15 21:34:24.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-15 21:34:24.000000000 +0300
@@ -2,7 +2,7 @@
import HAppS hiding (Body, getPath)
import Control.Monad.State
-import Data.Generics (Typeable)
+import Data.Generics (Typeable, Data, everywhere, mkT)
import Data.Binary hiding (get,put)
import Data.Maybe (fromJust)
import Data.Map (Map)
@@ -13,10 +13,10 @@
type Id = Int
data Item = Item { itemFields :: Map String String, itemCategories :: Set String }
- deriving (Read, Show, Typeable)
+ deriving (Read, Show, Typeable, Data)
data Type = Type { typeQuestion :: String }
- deriving (Read, Show, Typeable)
+ deriving (Read, Show, Typeable, Data)
catType name = Type ("which " ++ name ++ "?")
string = Type "which string?"
@@ -25,29 +25,53 @@
| FieldFun String String
| CatFun String
| AddItemFun String [String]
- deriving (Read, Show, Typeable)
+ deriving (Read, Show, Typeable, Data)
+
+readFun :: MyState -> String -> Fun
+readFun s n | ((r,""):_) <- reads n = r
+ | otherwise = statePotions s Map.! n
funTypes (Fun ts _ _) = ts
funTypes (FieldFun cat _) = [catType cat]
-funTypes (CatFun _) = []
+funTypes (CatFun _) = []
funParts (Fun _ ps _) = ps
funParts (FieldFun _ name) = ["the "++name++" of ", ""]
funParts (CatFun cat) = ["all " ++ cat ++ "s"]
-data Exp = Call Fun [Maybe Exp]
+data Exp = Call String [Maybe Exp]
| Var Int
| Forall Int Exp Exp
| HTML [Exp]
| Str String
- deriving (Read, Show, Typeable)
+ deriving (Read, Show, Typeable, Data)
-renderExp :: Exp -> String
-renderExp (Call fun args) = f (funTypes fun) (funParts fun) args where
+renderExp :: (?state :: MyState) => Exp -> String
+renderExp (Call fname args) = f (funTypes fun) (funParts fun) args where
+ fun = readFun ?state fname
f [] [x] _ = x
f (t:ts) (x:xs) (y:ys) =
- x ++ maybe ("[" ++ typeQuestion t ++ "]") renderExp y ++ f ts xs ys
-renderExp (Var i) = "<i>" ++ [toEnum (fromEnum 'a' + i)] ++ "</i>"
+ x ++ maybe ("[" ++ typeQuestion t ++ "]") renderExp' y ++ f ts xs ys
+renderExp (Var i) = renderVar i
+renderExp (Forall i exp body) = "For " ++ renderExp' exp
+ ++ " " ++ renderVar i ++ ":\n"
+ ++ "<blockquote>\n" ++ renderExp body
+ ++ "</blockquote>"
+renderExp (Str s) = "\"" ++ quote s ++ "\""
+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>"
+
+
+quote "" = ""
+quote ('<':cs) = "<" ++ quote cs
+quote ('"':cs) = """ ++ quote cs
+quote ('\'':cs) = "'" ++ quote cs
+quote ('&':cs) = "&" ++ quote cs
+quote (c:cs) = c : quote cs
+
+renderVar i = "<i>" ++ [toEnum (fromEnum 'a' + i)] ++ "</i>"
isComplete :: Exp -> Bool
isComplete (Call _ args) = all (maybe False isComplete) args
@@ -60,8 +84,10 @@
type Value = String
runExp :: Env -> Exp -> StateT MyState [] Value
-runExp env (Call fn args) = do vals <- mapM (runExp env . fromJust) args
- runFun fn vals
+runExp env (Call fname args) = do
+ state <- get; let fn = readFun state fname
+ vals <- mapM (runExp env . fromJust) args
+ runFun fn vals
runExp env (Forall v exp body) = do state <- get
let xs = evalStateT (runExp env exp) state
rs <- forM xs $ \x ->
@@ -94,7 +120,7 @@
data MyState = MyState { stateItems :: Map Id Item,
stateSchema :: Map String [String],
statePotions :: Map String Fun }
- deriving (Read, Show, Typeable)
+ deriving (Read, Show, Typeable, Data)
instance Binary MyState where
@@ -114,15 +140,15 @@
(Set.fromList ["post"]))
])
(Map.fromList [
- ("list", Fun [] ["List of all posts"] potion)
- , ("addPostForm", Fun [] ["foo"] addPostForm)
- , ("addPost", addPost)
+ ("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)
])
-potion = Forall 0 (Call (CatFun "post") []) $
- HTML [Str "<h2>", Call (FieldFun "post" "title") v, Str "</h2>\n",
- Str "<p>Author: ", Call (FieldFun "post" "author") v,
- Str "<p>", Call (FieldFun "post" "body") v,
+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>"]
where v = [Just $ Var 0]
@@ -135,8 +161,8 @@
\<input type=submit>\n\
\</form>"
-addPost = Fun [string, string, string] ["","","",""] $
- Call (AddItemFun "post" ["title","author","body"]) [Just (Var i) | i <- [0..2]]
+addPost =
+ Call (show $ AddItemFun "post" ["title","author","body"]) [Just (Var i) | i <- [0..2]]
view = do
(state :: MyState) <- get
@@ -162,9 +188,11 @@
instance FromMessage String where
fromMessageM m = lookM m "name"
-instance FromMessage [Value] where
+instance FromMessage (Exp, [Value]) where
fromMessageM m = do let n = maybe 0 read (lookM m "count")
- forM [1..n] $ \i -> lookM m ("arg" ++ show i)
+ vals <- forM [1..n] $ \i -> lookM m ("arg" ++ show i)
+ exp <- lookM m "exp"
+ return (read exp, vals)
addField cat name = do
state <- get
@@ -177,19 +205,35 @@
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 _ _ = Nothing
+
+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
+
main = stdHTTP [ debugFilter
- , h (Prefix ["potion"]) GET $ ok $ \[p] args -> do
+ , h (Prefix ["potion"]) GET $ ok $ \() (exp,args) -> do
s <- get
- let fun = statePotions s Map.! p
- respond $ head $ evalStateT (runFun fun args) s
- , h (Prefix ["potion"]) POST $ ok $ \[p] args -> do
+ let env = Map.fromList $ zip [0..length args-1] args
+ lnk = case expand s exp of
+ Just e -> " [<a href='?exp="++quote (show e)++"'>"
+ ++ "expand definition</a>]"
+ Nothing -> ""
+ respond $ let ?state=s in renderExp exp ++ lnk ++ "<hr>\n"
+ ++ (head $ evalStateT (runExp env exp) s)
+ , h (Prefix ["potion"]) POST $ ok $ \() (exp,args) -> do
s <- get
- let fun = statePotions s Map.! p
- (r,s') = case runStateT (runFun fun args) s of
+ 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)
put s'
- respond r
+ respond $ let ?state=s in renderExp exp ++ "<hr>\n" ++ r
, h () GET $ ok $ \() () -> view
, h ["addfield"] POST $ ok $ \() (cid,name) -> addField cid name
More information about the Fencommits
mailing list