[Fencommits] fenserve: a potion for creating a link to the page for creating a new item in a given category; fixes to sidebar functionality
Benja Fallenstein
benja.fallenstein at gmail.com
Fri May 25 20:08:16 EEST 2007
Fri May 25 20:08:08 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* a potion for creating a link to the page for creating a new item in a given category; fixes to sidebar functionality
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-25 20:08:16.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-25 20:08:16.000000000 +0300
@@ -39,7 +39,7 @@
(Map.fromList [
("Blog_post_archive", Fun [] [HTML "Blog post archive"] potion)
])
- [Call "Blog_post_archive" []]
+ [("Blog_post_archive", [])]
potion = Concat [Just $ Forall (catType "post") 0 (Just $ AllItems "post") $
Concat (map Just [Str "<h2>", Field "post" "title" v, Str "</h2>",
@@ -110,9 +110,16 @@
else toHTML "(Incomplete expression.)"
expanded = expand s exp
expandLink = (para $ link (?root++"potion?exp="++escape' (show e)++"&name="++n) "[edit page]")
- +++ if exp `elem` stateSidebarPages s then HTML "" else
- (para $ formP (?root++"addToSidebar") (hidden "exp" (show exp)
- +++ button "[add to sidebar]"))
+ +++ maybe (HTML "") (\page ->
+ (if page `elem` stateSidebarPages s then HTML "" else
+ para $ formP (?root++"addToSidebar") (hidden "page" (show page)
+ +++ button "[add to sidebar]")))
+ (case exp of
+ Call fun args -> fmap (\a -> (fun,a)) $
+ sequence args >>=
+ mapM (\a -> case a of Str s -> Just s
+ _ -> Nothing)
+ _ -> Nothing)
where Just (e,n) = expanded
potionGet exp args name s = (makePage s "Custom page" "" $
@@ -201,9 +208,9 @@
f "" part = ([reverse part], [])
addToSidebar :: Request -> MyState -> (String, MyState)
-addToSidebar msg s = ("potion?exp="++escape' (show exp), s') where
- s' = s { stateSidebarPages = stateSidebarPages s ++ [read exp] }
- Just exp = lookM msg "exp"
+addToSidebar msg s = ("potion/"++fn++concat ["/"++a | a <- args], s') where
+ s' = s { stateSidebarPages = stateSidebarPages s ++ [page] }
+ Just page@(fn,args) = fmap read $ lookM msg "page"
showTable :: () -> MyState -> (HTML, MyState)
showTable () s = (
@@ -284,7 +291,7 @@
, h ["newItem"] POST $ seeOther $ \() -> runRedirect newItem
, h ["delItem"] POST $ seeOther $ \() -> runRedirect delItem
- , h [""] GET $ seeOther $ \() -> runRedirect $ \() s -> ("potion?exp=" ++ (escape' $ show $ head $ stateSidebarPages s), s)
+ , h [""] GET $ seeOther $ \() -> runRedirect $ \() s -> ("potion/" ++ (case head $ stateSidebarPages s of (fn,args) -> fn ++ concat ["/"++a | a <- args]), s)
, h ["addField"] GET $ ok $ \() req ->
let Just cat = lookM req "category"
Just item = lookM req "item"
diff -rN -u old-fenserve/fendata/PotionTypes.hs new-fenserve/fendata/PotionTypes.hs
--- old-fenserve/fendata/PotionTypes.hs 2007-05-25 20:08:16.000000000 +0300
+++ new-fenserve/fendata/PotionTypes.hs 2007-05-25 20:08:16.000000000 +0300
@@ -24,6 +24,7 @@
data Exp = Call String [Maybe Exp]
| Field Category Field (Maybe Exp)
| AllItems Category
+ | NewItemButton Category
| Var Int
| Forall Type Int (Maybe Exp) Exp -- body should always be a Concat
| Concat [Maybe Exp]
@@ -47,7 +48,7 @@
data MyState = MyState { stateItems :: Map Id Item,
stateSchema :: Map String [String],
statePotions :: Map String Fun,
- stateSidebarPages :: [Exp] }
+ stateSidebarPages :: [(String, [String])] }
deriving (Read, Show, Typeable, Data)
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-05-25 20:08:16.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-05-25 20:08:16.000000000 +0300
@@ -30,6 +30,7 @@
getPotions s = map f (Map.toList $ statePotions s)
++ concatFor (Map.toList $ stateSchema s) (\(cat,fs) ->
AllItems cat
+ : NewItemButton cat
: Forall (catType cat) 0 Nothing (Concat [])
: map (\f -> Field cat f Nothing) fs) where
f (n, Fun ts _ _) = Call n (replicate (length ts) Nothing)
@@ -37,6 +38,7 @@
expType (Call fun _) = funType $ readFun ?state fun
expType (Field _ _ _) = string
expType (AllItems cat) = catType cat
+expType (NewItemButton cat) = string
expType (Var _) = error "no type inference yet"
expType (Forall _ _ _ _) = string
expType (Concat _) = string
@@ -68,6 +70,7 @@
f ts xs [] n = f ts xs [Just $ Str "0"] n
renderExp e0@(Field cat field exp) cx ty = editLink cx e0 ty ("the " +++ field +++ " of ") +++ renderMaybeExp' exp (\e -> cx $ Field cat field $ Just e) (catType cat) where
renderExp e0@(AllItems cat) cx ty = editLink cx e0 ty ("all the "++cat++"s in the system")
+renderExp e0@(NewItemButton cat) cx ty = editLink cx e0 ty ("a link for creating a new "++cat)
renderExp exp@(Var i) cx ty = editLink cx exp ty (renderVar i)
renderExp e0@(Forall t i exp body) cx _ = editLink cx e0 string "For each of " +++ renderMaybeExp' exp (\e -> cx $ Forall t i (Just e) body) t
+++ editLink cx e0 string (" (call it '" +++ renderVar i +++ "'):\n")
@@ -88,12 +91,13 @@
isComplete (Call _ args) = all (maybe False isComplete) args
isComplete (Field _ _ exp) = maybe False isComplete exp
isComplete (AllItems _) = True
+isComplete (NewItemButton _) = True
isComplete (Forall _ _ exp body) = maybe False isComplete exp && isComplete body
isComplete (Var _) = True
isComplete (Concat exps) = all (maybe False isComplete) exps
isComplete (Str _) = True
-runExp :: Env -> Exp -> StateT MyState [] Value
+runExp :: (?root :: String) => Env -> Exp -> StateT MyState [] Value
runExp env (Call fname args) = do
state <- get; let fn = readFun state fname
vals <- mapM (runExp env . fromJust) args
@@ -105,6 +109,10 @@
runExp env (AllItems cat) = do
state <- get
msum [return $ show n | (n, Item _ cs) <- Map.toList (stateItems state), cat `Set.member` cs]
+runExp env (NewItemButton cat) = do
+ return $ html $ formP (?root++"newItem") $
+ hidden "returnTo" "" +++
+ button' "cat" cat (bold ("[Create a new "+++cat+++"]"))
runExp env (Forall _ v (Just exp) body) = do
state <- get; let xs = evalStateT (runExp env exp) state
rs <- forM xs $ \x -> runExp (Map.insert v x env) body
diff -rN -u old-fenserve/fendata/UI.hs new-fenserve/fendata/UI.hs
--- old-fenserve/fendata/UI.hs 2007-05-25 20:08:16.000000000 +0300
+++ new-fenserve/fendata/UI.hs 2007-05-25 20:08:16.000000000 +0300
@@ -40,10 +40,12 @@
tag "div" [("class", "main")] (
tag "div" [("class", "sidebar")] (
para "Welcome to Fendata!" +++ sidebar +++ hr +++
- catFor (stateSidebarPages state) (\exp ->
+ catFor (stateSidebarPages state) (\(fun, args) ->
let ?state=state; ?link=False; ?name=Nothing
- in para $ bold $ link (?root++"potion?exp="++escape' (show exp)) $
- renderExp exp id string) +++ hr +++
+ in let exp = Call fun (map (Just . Str) args)
+ uri = ?root++"potion/"++fun++concat ["/"++a | a <- args]
+ in para $ bold $ link uri $ renderExp exp id string) +++
+ hr +++
para (link (?root++"potion?exp="++(escape' $ show $ Concat [])) "New page") +++
para (link (?root++"table") "List of items in the database")) +++
tag "div" [("class", "content")] body) +++
More information about the Fencommits
mailing list