[Fencommits] fenserve: add plural types and a potion for 'today's date'
Tuukka Hastrup
Tuukka.Hastrup at iki.fi
Sat May 26 16:59:07 EEST 2007
Sat May 26 16:57:59 EEST 2007 Tuukka Hastrup <Tuukka.Hastrup at iki.fi>
* add plural types and a potion for 'today's date'
diff -rN -u old-fenserve-1/fendata/Main.hs new-fenserve-1/fendata/Main.hs
--- old-fenserve-1/fendata/Main.hs 2007-05-26 16:59:06.000000000 +0300
+++ new-fenserve-1/fendata/Main.hs 2007-05-26 16:59:06.000000000 +0300
@@ -15,6 +15,7 @@
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
+import Data.Int (Int64)
import qualified System.IO.Unsafe
import qualified Control.Exception
@@ -41,7 +42,7 @@
])
[("Blog_post_archive", [])]
-potion = Block [Just $ Forall (catType "post") 0 (Just $ AllItems "post") $
+potion = Block [Just $ Forall (pluralType "post") 0 (Just $ AllItems "post") $
Block (map Just [Str "<h2>", Field "post" "title" v, Str "</h2>",
Str "\n<p>Author: ", Field "post" "author" v,
Str "\n<p>", Field "post" "body" v,
@@ -269,10 +270,12 @@
Just id = fmap read $ lookM msg "item"
main = stdHTTP [ debugFilter
- , h ["potion"] GET $ ok $ \() -> run $
- \req s -> let ?root = "" in potionGet (read $ fromJust $ lookM req "exp") (readArgs req) (lookM req "name") s
- , h (Prefix ["potion"]) GET $ ok $ \(fun:args) -> run $
- \req s -> let ?root = concat (take (1 + length args) $ repeat "../") in potionPage fun args (lookM req "name") s
+ , h ["potion"] GET $ ok $ \() req -> (getTime >>=) $ run $
+ \time s -> let ?root = ""; ?time = time in potionGet (read $ fromJust $ lookM req "exp") (readArgs req) (lookM req "name") s
+ , h (Prefix ["potion"]) GET $ ok $ \(fun:args) req -> do
+ time <- getTime
+ let { ?time = time } in flip run req $
+ \req s -> let ?root = concat (take (1 + length args) $ repeat "../") in potionPage fun args (lookM req "name") s
, h ["edit"] GET $ ok $ \() -> run $ \req ->
edit (read $ fromJust $ lookM req "exp",
read $ fromJust $ lookM req "old",
diff -rN -u old-fenserve-1/fendata/Potions.hs new-fenserve-1/fendata/Potions.hs
--- old-fenserve-1/fendata/Potions.hs 2007-05-26 16:59:06.000000000 +0300
+++ new-fenserve-1/fendata/Potions.hs 2007-05-26 16:59:06.000000000 +0300
@@ -15,8 +15,14 @@
import Data.Set (Set)
import qualified Data.Set as Set
-catType name = Type ("which " ++ name ++ "?")
-string = Type "which text?"
+import Data.Int (Int64)
+
+import Text.Printf (printf)
+import System.Time
+
+catType cat = Type cat
+pluralType cat = Type (cat ++ "s")
+string = Type "text"
readFun :: MyState -> String -> Fun
readFun s n = statePotions s Map.! n
@@ -29,10 +35,11 @@
getPotions :: MyState -> [Exp]
getPotions s = map f (Map.toList $ statePotions s)
+ ++ [Today]
++ concatFor (Map.toList $ stateSchema s) (\(cat,fs) ->
AllItems cat
: NewItemButton cat
- : Forall (catType cat) 0 Nothing (Block [])
+ : Forall (pluralType cat) 0 Nothing (Block [])
: concatFor fs (\f -> [ Field cat f Nothing
, SortByField cat f 1 Nothing
, SortByField cat f (-1) Nothing
@@ -44,15 +51,16 @@
expType (Call fun _) = funType $ readFun ?state fun
expType (Field _ _ _) = string
-expType (AllItems cat) = catType cat
+expType (AllItems cat) = pluralType cat
expType (NewItemButton cat) = string
expType (Var _) = error "no type inference yet"
-expType (SortByField cat _ _ _) = catType cat
-expType (FilterByField cat _ _ _ _) = catType cat
+expType (SortByField cat _ _ _) = pluralType cat
+expType (FilterByField cat _ _ _ _) = pluralType cat
expType (Forall _ _ _ _) = string
expType (Block _) = string
expType (Inline _) = string
expType (Str _) = string
+expType (Today) = string
editLink :: (?link :: Bool, ?name :: Maybe String, ?root :: String,
ToHTML a) => (Exp -> Exp) -> Exp -> Type -> a -> HTML
@@ -82,8 +90,9 @@
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@(SortByField cat field i exp) cx ty = renderMaybeExp' exp (\e -> cx $ SortByField cat field i $ Just e) (catType cat) +++ editLink cx e0 ty (", sorted by "++field++if i<0 then ", descending" else ", ascending")
-renderExp e0@(FilterByField cat field i exp exp0) cx ty = editLink cx e0 ty "those of " +++ renderMaybeExp' exp (\e -> cx $ FilterByField cat field i (Just e) exp0) (catType cat) +++ editLink cx e0 ty (" whose "++field++if i<0 then " comes before " else if i>0 then " comes after " else " is ") +++ renderExp exp0 (\e -> cx $ FilterByField cat field i exp e) string
+renderExp Today cx ty = editLink cx Today ty "today's date"
+renderExp e0@(SortByField cat field i exp) cx ty = renderMaybeExp' exp (\e -> cx $ SortByField cat field i $ Just e) (pluralType cat) +++ editLink cx e0 ty (", sorted by "++field++if i<0 then ", descending" else ", ascending")
+renderExp e0@(FilterByField cat field i exp exp0) cx ty = editLink cx e0 ty "those of " +++ renderMaybeExp' exp (\e -> cx $ FilterByField cat field i (Just e) exp0) (pluralType cat) +++ editLink cx e0 ty (" whose "++field++if i<0 then " comes before " else if i>0 then " comes after " else " is ") +++ renderExp exp0 (\e -> cx $ FilterByField cat field i exp e) string
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")
+++ tag' "blockquote" (renderExp body (\e -> cx $ Forall t i exp e) string)
@@ -112,8 +121,9 @@
isComplete (Block exps) = all (maybe False isComplete) exps
isComplete (Inline exps) = all (maybe False isComplete) exps
isComplete (Str _) = True
+isComplete (Today) = True
-runExp :: (?root :: String) => Env -> Exp -> StateT MyState [] Value
+runExp :: (?root :: String, ?time :: Int64) => Env -> Exp -> StateT MyState [] Value
runExp env (Call fname args) = do
state <- get; let fn = readFun state fname
vals <- mapM (runExp env . fromJust) args
@@ -152,6 +162,11 @@
runExp env (Inline exps) = do rs <- mapM (\(Just e) -> runExp env e) exps
return $ concat rs
runExp _ (Str s) = return s
+runExp _ Today = return $ renderTime ?time
+
+renderTime :: Int64 -> String
+renderTime t0 = printf "%04u-%02u-%02u" (ctYear t) (fromEnum (ctMonth t)+1) (ctDay t)
+ where t = toUTCTime (TOD (fromIntegral t0) 0)
runFun (Fun _ _ body) args =
runExp (Map.fromList [(i, args!!i) | i <- [0..length args-1]]) body
diff -rN -u old-fenserve-1/fendata/PotionTypes.hs new-fenserve-1/fendata/PotionTypes.hs
--- old-fenserve-1/fendata/PotionTypes.hs 2007-05-26 16:59:06.000000000 +0300
+++ new-fenserve-1/fendata/PotionTypes.hs 2007-05-26 16:59:06.000000000 +0300
@@ -16,7 +16,7 @@
data Type = Type String
deriving (Read, Show, Typeable, Data, Eq, Ord)
-typeQuestion (Type s) = s
+typeQuestion (Type s) = "which " ++ s ++ "?"
data Fun = Fun [Type] [HTML] Exp
deriving (Read, Show, Typeable, Data, Eq, Ord)
@@ -31,6 +31,7 @@
| Forall Type Int (Maybe Exp) Exp -- body should always be a Block
| Block [Maybe Exp] | Inline [Maybe Exp]
| Str String
+ | Today
deriving (Read, Show, Typeable, Data, Eq, Ord)
diff -rN -u old-fenserve-1/fendata/UI.hs new-fenserve-1/fendata/UI.hs
--- old-fenserve-1/fendata/UI.hs 2007-05-26 16:59:06.000000000 +0300
+++ new-fenserve-1/fendata/UI.hs 2007-05-26 16:59:06.000000000 +0300
@@ -13,12 +13,12 @@
\ font: inherit; margin: 0; padding: 0 } \
\.potion, .editPotion {\
\ border: dashed black 1px; padding: 2px; \
- \ margin: 2px; line-height: 200% } \
- \span.editPotion:hover { background: #eee } \
- \span.editPotion:hover span.editPotion:hover { background: #ddd } \
- \span.editPotion:hover span.editPotion:hover span.editPotion:hover { background: #ccc } \
- \span.editPotion:hover span.editPotion:hover span.editPotion:hover { background: #bbb } \
- \span.editPotion:hover span.editPotion:hover span.editPotion:hover span.editPotion:hover { background: #aaa } \
+ \ margin: 2px; line-height: 1.8em } \
+ \span.editPotion { background: #eee } \
+ \span.editPotion span.editPotion { background: #ddd } \
+ \span.editPotion span.editPotion span.editPotion { background: #ccc } \
+ \span.editPotion span.editPotion span.editPotion span.editPotion { background: #bbb } \
+ \span.editPotion span.editPotion span.editPotion span.editPotion span.editPotion { background: #aaa } \
\.footer { font-size: small; font-style:italic; color: #888; \
\ padding-top: 2em; clear: both; text-align: justify } \
\.logo {border: 2px solid #eee; margin: 0.5em; float: left} \
More information about the Fencommits
mailing list