[Fencommits] fenserve: use new HTML module in most places
Benja Fallenstein
benja.fallenstein at gmail.com
Wed May 23 21:49:22 EEST 2007
Wed May 23 21:49:09 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* use new HTML module in most places
diff -rN -u old-fenserve-1/fendata/HTML.hs new-fenserve-1/fendata/HTML.hs
--- old-fenserve-1/fendata/HTML.hs 2007-05-23 21:49:22.000000000 +0300
+++ new-fenserve-1/fendata/HTML.hs 2007-05-23 21:49:22.000000000 +0300
@@ -2,7 +2,9 @@
module HTML where
-newtype HTML = HTML String deriving (Read, Show, Eq, Ord)
+import Data.Generics (Typeable, Data)
+
+newtype HTML = HTML String deriving (Read, Show, Eq, Ord, Typeable, Data)
class ToHTML a where
toHTML :: a -> HTML
@@ -30,28 +32,34 @@
toHTML = id
instance ToHTML String where
- toHTML = HTML . quote
+ toHTML = HTML . concatMap quoteChar
-quote = concatMap quoteChar
-quoteBr = concatMap (\c -> case c of '\n' -> "<br>"; _ -> quoteChar c)
-quoteP = concatMap (\c -> case c of '\n' -> "<p>"; _ -> quoteChar c)
+quoteBr = HTML . concatMap (\c -> case c of '\n' -> "<br>"; _ -> quoteChar c)
+quoteP = HTML . concatMap (\c -> case c of '\n' -> "<p>"; _ -> quoteChar c)
quoteChar c = case c of '<' -> "<"; '"' -> """; '\'' -> "'"
'&' -> "&"; _ -> [c]
tag :: ToHTML a => String -> [(String,String)] -> a -> HTML
-tag name attrs content = "<"+++name+++a+++">"+++content+++"</"+++name+++">"
- where a = catFor attrs $ \(a,v) -> " "+++a+++"='"+++v+++"'>"
+tag name attrs content = HTML "<"+++name+++a+++HTML ">"+++content
+ +++HTML "</"+++name+++HTML ">"
+ where a = catFor attrs $ \(a,v) -> " "+++a+++HTML "='"+++v+++HTML "'"
+
+tag' name = tag name []
etag :: String -> [(String,String)] -> HTML
-etag name attrs = "<"+++name+++a+++">"
- where a = catFor attrs $ \(a,v) -> " "+++a+++"='"+++v+++"'>"
+etag name attrs = HTML "<"+++name+++a+++HTML ">"
+ where a = catFor attrs $ \(a,v) -> " "+++a+++HTML "='"+++v+++HTML "'"
style s = tag "span" [("style", s)]
bold x = style "font-weight: bold" x
ital x = style "font-style: italic" x
color c x = style ("color: "++c) x
+code x = tag "code" [] x
+
+h1 x = tag "h1" [] x; h2 x = tag "h2" [] x; h3 x = tag "h3" [] x
+ul x = tag "ul" [] x; ol x = tag "ol" [] x; li x = tag "li" [] x
link href = tag "a" [("href", href)]
@@ -65,6 +73,12 @@
hidden name value = input "hidden" name value
textfield name value = input "text" name value
-textarea name x = tag "textarea" [] x
-button x = tag "button" [("style", "cursor: pointer; background: none; border: none; font: inherit; margin: 0; padding: 0")] x
+textarea name rows cols x =
+ tag "textarea" [("rows", show rows), ("cols", show cols)] x
+button x = tag "button" [("style", buttonStyle)] x
+button' name value x = tag "button" [("name", name), ("value", value),
+ ("style", buttonStyle)] x
+submit caption = input "submit" "" caption
+
+buttonStyle = "cursor: pointer; background: none; border: none; font: inherit; margin: 0; padding: 0"
diff -rN -u old-fenserve-1/fendata/Main.hs new-fenserve-1/fendata/Main.hs
--- old-fenserve-1/fendata/Main.hs 2007-05-23 21:49:22.000000000 +0300
+++ new-fenserve-1/fendata/Main.hs 2007-05-23 21:49:22.000000000 +0300
@@ -17,7 +17,7 @@
import qualified System.IO.Unsafe
import qualified Control.Exception
-header = "<head><style>a { text-decoration: none; color: inherit; }\
+header = HTML "<head><style>a { text-decoration: none; color: inherit; }\
\button {cursor: pointer; background: none; border: none; font: inherit; margin: 0; padding: 0}</style></head>"
type Id = Int
@@ -32,7 +32,7 @@
string = Type "which text?"
action = Type "Do what?"
-data Fun = Fun [Type] [String] Exp
+data Fun = Fun [Type] [HTML] Exp
| FieldFun String String
| CatFun String
| AddItemFun String [String]
@@ -53,9 +53,10 @@
funTypes (AddItemFun _ fs) = map (const string) fs
funParts (Fun _ ps _) = ps
-funParts (FieldFun _ name) = ["the "++name++" of ", ""]
-funParts (CatFun cat) = ["the " ++ cat ++ "s in the system"]
-funParts (AddItemFun cat fs) = ["Add a new "++cat++" with "] ++
+funParts (FieldFun _ name) = map toHTML ["the "++name++" of ", ""]
+funParts (CatFun cat) = map toHTML ["the " ++ cat ++ "s in the system"]
+funParts (AddItemFun cat fs) = map toHTML $
+ ["Add a new "++cat++" with "] ++
[" as the "++f++", and " | f <- init fs] ++
[" as the "++last fs++"."]
@@ -86,40 +87,36 @@
expType (Concat _) = 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>"
+editLink :: (?link :: Bool, ToHTML a) => (Exp -> Exp) -> Exp -> Type -> a -> HTML
+editLink f old t s | not ?link = toHTML s | otherwise = flip link s $
+ "edit?exp="++(show $ f $ Var (-1))++"&old="++show old++"&type="++show t
renderMaybeExp (Just exp) cx ty = renderExp' exp cx ty
-renderMaybeExp Nothing cx ty = editLink cx (Var 0) ty $ surround
- $ "<b style='color: maroon'>[" ++ typeQuestion ty
- ++ "]</b>"
+renderMaybeExp Nothing cx ty = editLink cx (Var 0) ty $ surround $ bold $
+ "[" +++ typeQuestion ty +++ "]"
-renderExp :: (?state :: MyState, ?link :: Bool) => Exp -> (Exp -> Exp) -> Type -> String
+renderExp :: (?state :: MyState, ?link :: Bool) => Exp -> (Exp -> Exp) -> Type -> HTML
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 ty x
f (t:ts) (x:xs) (y:ys) n =
- editLink cx exp ty x ++ renderMaybeExp y (cx' n) t ++ f ts xs ys (n+1)
+ editLink cx exp ty x +++ renderMaybeExp y (cx' n) t +++ 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 of " ++ renderExp' exp (\e -> cx $ Forall i e body) (expType exp)
- ++ " (call it '" ++ renderVar i ++ "'):\n"
- ++ "<blockquote>\n" ++ renderExp body (\e -> cx $ Forall i exp e) string
- ++ "</blockquote>"
-renderExp (Str s) cx _ = "<small>" ++ quoteP s ++ "</small>"
-renderExp exp@(Concat exps) cx _ = "<p>" ++ concatMap (\(xs,x,xs') -> renderMaybeExp x (\e -> cx (Concat (xs ++ [Just e] ++ xs'))) string) (slices exps) ++ if ?link then "<p>" ++ editLink cx exp string "[edit]" else ""
+renderExp (Forall i exp body) cx _ = "For each of " +++ renderExp' exp (\e -> cx $ Forall i e body) (expType exp)
+ +++ " (call it '" +++ renderVar i +++ "'):\n"
+ +++ tag' "blockquote" (renderExp body (\e -> cx $ Forall i exp e) string)
+renderExp (Str s) cx _ = tag "small" [] $ quoteP s
+renderExp exp@(Concat exps) cx _ = para $ catMap (\(xs,x,xs') -> renderMaybeExp x (\e -> cx (Concat (xs ++ [Just e] ++ xs'))) string) (slices exps) +++ if ?link then para $ editLink cx exp string "[edit]" else toHTML ""
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; line-height: 90%;'>" ++ s ++ "</span>"
+surround s = style "border: dashed black 1px; padding: 2px; margin: 2px; line-height: 90%;" s
slices xs = map (\i -> (take i xs, xs !! i, drop (i+1) xs)) [0..length xs-1]
-renderVar i = "<i>" ++ [toEnum (fromEnum 'a' + i)] ++ "</i>"
+renderVar i = ital [toEnum (fromEnum 'a' + i) :: Char]
isComplete :: Exp -> Bool
isComplete (Call _ args) = all (maybe False isComplete) args
@@ -188,9 +185,8 @@
(Set.fromList ["post"]))
])
(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 ", " as the title, ", " as the author, and ", " as the body."] addPost)
+ ("list", Fun [] [HTML "A list of all posts"] potion)
+ , ("addPostForm", Fun [] [HTML "Form for adding posts"] addPostForm)
])
potion = Forall 0 (Call (show $ CatFun "post") []) $
@@ -230,9 +226,9 @@
++ "</form>"
++ concatMap category (Map.toList $ stateSchema state)
-}
- respond $ header ++ (concatFor (getPotions state) $ \exp ->
- "<p><a href='potion?exp=" ++ (quote $ escape $ show exp) ++ "'>"
- ++ let ?state = state; ?link=False in renderExp' exp id string ++ "</a>\n")
+ respond $ html $ header +++ (catFor (getPotions state) $ \exp ->
+ para $ link ("potion?exp="++(escape $ show exp)) $
+ let ?state = state; ?link=False in renderExp' exp id string)
instance FromMessage (String,String) where
fromMessageM m = do cat <- lookM m "category"; name <- lookM m "name"
@@ -296,67 +292,59 @@
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 $ header ++ s
+ Right (s, state') -> do put state'; respond $ html (header +++ s)
Left e -> respond $ "Internal server error: " ++ show e
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>")
+ Right (s, state') -> do put state'; respond (s, html $ link s "link")
Left e -> respond $ ("", "Internal server error: " ++ show e)
potionGet exp args s = (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.)"
+ renderExp exp id string +++ " " +++ lnk +++ hr
+ +++ if (isComplete exp)
+ then (HTML $ head $ evalStateT (runExp env exp) s)
+ else toHTML "(Incomplete expression.)"
, s) where
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 -> " [<a href='makefun?exp="
- ++ quote (show exp) ++ "'>save</a>]"
+ Just e -> link ("?exp="++show e) "[expand definition]"
+ Nothing -> link ("makefun?exp="++show exp) "[save]"
potionPost exp args s = (let ?state=s; ?link=True in
- renderExp exp id action ++ "<hr>\n" ++ r
+ renderExp exp id action +++ hr +++ HTML r
, s') where
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)
-edit :: (Exp,Exp,Type) -> MyState -> (String, MyState)
+edit :: (Exp,Exp,Type) -> MyState -> (HTML, MyState)
edit (exp,old@(Concat olds),ty) s = let ?state = s; ?link = False in
- ("<form action='editTemplate' method='get'>\
- \ <p><textarea name='template' rows='20' cols='80'>"
- ++ quote (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 (Just (Str s) : xs) = s ++ f i xs
- f i (_:xs) = "$" ++ show i ++ f (i+1) xs
- f _ [] = ""
+ (formG "editTemplate" $
+ para (textarea "template" 20 80 $ f 1 olds)
+ +++ para (submit "Submit" +++ hidden "exp" (show exp)
+ +++ hidden "old" (show old)), s) where
+ f i (Just (Str s) : xs) = s +++ f i xs
+ f i (_:xs) = "$" +++ show i +++ f (i+1) xs
+ f _ [] = toHTML ""
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 (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>"
+ (para ("Select something to replace '" +++ renderExp' old id ty +++ "' "
+ +++ "with.") +++ hr
+ +++ para ("Variables: " +++ cat [linkExp (Var i) (surround $ renderVar i)+++" "
+ | i <- [0..25]])
+ +++ (catFor (filter ((==ty) . expType) $ getPotions s) $ \repl ->
+ para $ li $ linkExp repl $ renderExp' repl id (error "some type"))
+ , s) where linkExp new = link $ "potion?exp=" ++ show (subst (-1) new exp)
-makeFun :: Request -> MyState -> (String, MyState)
+makeFun :: Request -> MyState -> (HTML, MyState)
makeFun msg s = let ?state = s; ?link = False in
- ("<p>Save '"++renderExp' exp id (error "some type")++"'\
- \as the following potion (<code>$</code> marks a hole):\
- \<form action='addpotion' method='post'>\
- \ <p><textarea name='template' rows='3' cols='80'></textarea>\
- \ <p><input type='submit' value='Save'>\
- \ <input type='hidden' name='exp' value='"++quote (show exp)++"'>\
- \</form>", s) where
- Just exp = fmap read $ lookM msg "exp"
+ (para ("Save '"+++renderExp' exp id (error "some type")+++"' as the "
+ +++ "following potion (" +++ code "$" +++ " marks a hole):")
+ +++ formP "addpotion" (para (textarea "template" 3 80 "")
+ +++ para (submit "Save") +++ hidden "exp" (show exp)), s)
+ where Just exp = fmap read $ lookM msg "exp"
editTemplate :: Request -> MyState -> (String, MyState)
editTemplate msg s =
@@ -382,60 +370,60 @@
name = map (\x -> case x of ' ' -> '_'; '$' -> 'X'; c -> c) template
parts = f template ""
types = take ((length parts) - 1) $ repeat string
- potion = Fun types parts exp
+ potion = Fun types (map toHTML parts) exp
newPotions = Map.insert name potion $ statePotions s
f ('$':cs) part = reverse part : f cs ""
f (c:cs) part = f cs (c:part)
f "" part = [reverse part]
-commaList :: [String] -> String
-commaList [] = ""
-commaList [x] = x
-commaList xs = concat (intersperse ", " $ init xs) ++ " and " ++ last xs
+commaList :: ToHTML a => [a] -> HTML
+commaList [] = toHTML ""
+commaList [x] = toHTML x
+commaList xs = cat (intersperse (toHTML ", ") $ map toHTML $ init xs)
+ +++ " and " +++ last xs
capitalize (c:cs) = toUpper c : cs
capitalize "" = ""
-showTable :: () -> MyState -> (String, MyState)
+showTable :: () -> MyState -> (HTML, MyState)
showTable () s = (
- (new++) . ("<hr>"++) . (++new) .
- concatFor (Map.toList $ stateItems s) $ \(id, Item fields cats) ->
- (++ "<p><form action='delItem' method=post>\
- \<input type=hidden name=item value='"++show id++"'>\
- \<a href='item/"++show id++"?returnTo=table'>[Edit item]</a> "++mdot++"\
- \<button style='cursor: pointer; background: none; border: none; font: inherit; margin: 0; padding: 0'>[Delete item]</button> " ++ mdot ++
- " <i>Categorized as " ++
- commaList (map (("<b>"++).(++"</b>").capitalize) (Set.toList cats)) ++
- "</i></form><hr>")
- . ("<p>"++)
- . concatFor (Map.toList fields) $ \(f:fs,v) ->
- "<b>" ++ (toUpper f : fs) ++ ":</b> " ++ v ++ "<br>",
- s) where new = ("<p><form action='newItem' method=post>\
- \<input type=hidden name=returnTo value=table>" ++) .
- (++"<a href='addCategory'>[Add category]</a></form>") .
- concatFor (Map.keys $ stateSchema s) $ \cat ->
- "<button style='cursor: pointer; background: none; border: none; font: inherit; margin: 0; padding: 0' name=cat value='"++cat++"'>[New "++cat++"]</button>"++mdot
-
+ (new+++) . (hr+++) . (+++new) .
+ catFor (Map.toList $ stateItems s) $ \(id, Item fields cats) ->
+ (+++ para (formP "delItem" (hidden "item" (show id) +++ mdotted
+ [ link ("item/"++show id++"?returnTo=table") "[Edit item]"
+ , button "[Delete item]"
+ , ital $ "Categorized as "
+ +++ commaList (map (bold.capitalize) (Set.toList cats))]))
+ +++ hr)
+ . para
+ . catFor (Map.toList fields) $ \(f,v) ->
+ bold (capitalize f) +++ ": " +++ v +++ br,
+ s) where new = para . formP "newItem" . (+++ hidden "returnTo" "table")
+ . (+++ " " +++ mdot +++ " " +++ link "addCategory" "[Add category]")
+ . mdotted . for (Map.keys $ stateSchema s) $ \cat ->
+ button' "cat" cat $ "[New "+++cat+++"]"
-mdot = "<span style='margin-left: 0.5em; margin-right: 0.5em; font-weight: bold'>·</span>"
+mdot = style "margin-left: 0.5em; margin-right: 0.5em; font-weight: bold" $
+ HTML "·"
+
+mdotted = cat . intersperse (" "+++mdot+++" ")
-showItem :: String -> Request -> MyState -> (String, MyState)
+showItem :: String -> Request -> MyState -> (HTML, MyState)
showItem item req s = let Item fields cats = stateItems s Map.! read item in (
- (("<form method=post>"++returnTo++buttons++"<hr>")++) .
- (++"<hr>"++buttons) .
- concatFor (Set.toList cats) $ \cat -> let cfs = stateSchema s Map.! cat in
- (("<h3>"++capitalize cat++"</h3><p>")++)
- . (++ "<p><a href='../addField?item="++item++"&category="++cat
- ++ "&returnTo=item/"++item++quote (escape ("?returnTo="++escape uri))
- ++ "'>[Add a field to the "++capitalize cat++" category]</a><br>")
- . concatFor cfs $ \field ->
- capitalize field ++ ": <input name='" ++ quote field ++ "' "
- ++ "value='" ++ quote (fields Map.! field) ++ "'><br>",
+ formP "" . ((returnTo+++buttons+++hr)+++) . (+++hr+++buttons) .
+ catFor (Set.toList cats) $ \cat -> let cfs = stateSchema s Map.! cat in
+ (h3 (capitalize cat) +++) . para
+ . (+++ HTML ("<p><a href='../addField?item="++item++"&category="++cat
+ ++ "&returnTo=item/"++item++html (escape ("?returnTo="++escape uri))
+ ++ "'>[Add a field to the "++capitalize cat++" category]</a><br>"))
+ . catFor cfs $ \field ->
+ capitalize field +++ ": " +++ textfield field (fields Map.! field)
+ +++ br,
s) where uri = fromMaybe "" (lookM req "returnTo")
- returnTo = flip (maybe "") (lookM req "returnTo") $ \uri ->
- "<input type=hidden name=returnTo value='"++quote(escape uri)++"'>"
- buttons = "<p><button>[Save]</button> "++mdot++" "++
- "<a href='../"++quote uri++"'>[Cancel]</a></form>"
+ returnTo = flip (maybe $ toHTML "") (lookM req "returnTo") $ \uri -> HTML $
+ "<input type=hidden name=returnTo value='"++html(escape uri)++"'>"
+ buttons = HTML $ "<p><button>[Save]</button> "++html mdot++" "++
+ "<a href='../"++html uri++"'>[Cancel]</a></form>"
updateItem :: String -> Request -> MyState -> (String, MyState)
@@ -487,7 +475,7 @@
\<form method=post>Field: <input name=field>\
\<input type=hidden name=category value='"++cat++"'>\
\<input type=hidden name=item value='"++item++"'>\
- \<input type=hidden name=returnTo value='"++quote returnTo++"'>\
+ \<input type=hidden name=returnTo value='"++html returnTo++"'>\
\<input type=submit value='Submit'></form>"
, h ["addField"] POST $ seeOther $ \() -> runRedirect addField
, h ["addCategory"] GET $ ok $ \() () -> respond $
More information about the Fencommits
mailing list