[Fencommits] fenserve: refactor: allow HTML to automatically apply 'show' to attribute values
Benja Fallenstein
benja.fallenstein at gmail.com
Thu May 31 01:23:39 EEST 2007
Thu May 31 01:23:25 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* refactor: allow HTML to automatically apply 'show' to attribute values
diff -rN -u old-fenserve/fendata/HTML.hs new-fenserve/fendata/HTML.hs
--- old-fenserve/fendata/HTML.hs 2007-05-31 01:23:38.000000000 +0300
+++ new-fenserve/fendata/HTML.hs 2007-05-31 01:23:38.000000000 +0300
@@ -1,14 +1,22 @@
-{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}
module HTML where
+import HAppS (lookM)
+
import Data.Generics (Typeable, Data)
+import Data.Maybe (fromMaybe)
newtype HTML = HTML String deriving (Read, Show, Eq, Ord, Typeable, Data)
+data Param key = forall value. ToString value => P key value
+
class ToHTML a where
toHTML :: a -> HTML
+class ToString a where
+ toString :: a -> String
+
fromHTML (HTML s) = s
html :: ToHTML a => a -> String
@@ -50,6 +58,9 @@
toHTML (a,b,c,d,e,f,g,h) = a & (b,c,d,e,f,g,h)
instance (ToHTML a, ToHTML (b,c,d,e,f,g,h,i)) => ToHTML (a,b,c,d,e,f,g,h,i) where
toHTML (a,b,c,d,e,f,g,h,i) = a & (b,c,d,e,f,g,h,i)
+
+instance ToString String where toString = id
+instance Show a => ToString a where toString = show
quoteBr = HTML . concatMap (\c -> case c of '\n' -> "<br>"; _ -> quoteChar c)
quoteP = HTML . concatMap (\c -> case c of '\n' -> "<p>"; _ -> quoteChar c)
@@ -57,18 +68,18 @@
quoteChar c = case c of '<' -> "<"; '"' -> """; '\'' -> "'"
'&' -> "&"; _ -> [c]
-tag :: ToHTML a => String -> [(String,String)] -> a -> HTML
-tag name attrs content = HTML "<"&name&a&HTML ">"&content
- &HTML "</"&name&HTML ">"
- where a = catFor attrs $ \(a,v) -> " "&a&HTML "='"&v&HTML "'"
+tag :: ToHTML a => String -> [Param String] -> a -> HTML
+tag name attrs content = HTML "<" & name & a & HTML ">" & content
+ & HTML "</" & name & HTML ">"
+ where a = catFor attrs $ \(P a v) -> " " & a & HTML "='" & toString v & HTML "'"
tag' name = tag name []
-etag :: String -> [(String,String)] -> HTML
-etag name attrs = HTML "<"&name&a&HTML ">"
- where a = catFor attrs $ \(a,v) -> " "&a&HTML "='"&v&HTML "'"
+etag :: String -> [Param String] -> HTML
+etag name attrs = HTML "<" & name & a & HTML ">"
+ where a = catFor attrs $ \(P a v) -> " " & a & HTML "='" & toString v & HTML "'"
-style s = tag "span" [("style", s)]
+style s = tag "span" [P "style" s]
bold x = style "font-weight: bold" x
ital x = style "font-style: italic" x
@@ -78,24 +89,25 @@
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)]
+link href = tag "a" [P "href" href]
-formG href = tag "form" [("action", href), ("method", "GET")]
-formP href = tag "form" [("action", href), ("method", "POST")]
+formG href = tag "form" [P "action" href, P "method" "GET"]
+formP href = tag "form" [P "action" href, P "method" "POST"]
br = HTML "<br>"; hr = HTML "<hr>"; para x = tag "p" [] x
input ty name value =
- etag "input" [("type", ty), ("name", name), ("value", value)]
+ etag "input" [P "type" ty, P "name" name, P "value" value]
hidden name value = input "hidden" name value
textfield name value = input "text" name value
-textarea name rows cols x =
- tag "textarea" [("name", name), ("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
+textarea name (rows::Int) (cols::Int) x =
+ tag "textarea" [P "name" name, P "rows" rows, P "cols" cols] x
+button x = tag "button" [P "style" buttonStyle] x
+button' name value x = tag "button" [P "name" name, P "value" value,
+ P "style" buttonStyle] x
submit caption = input "submit" "" caption
+channel fields = catFor fields $ \f -> hidden f (fromMaybe "" $ lookM ?req f)
buttonStyle = "cursor: pointer; background: none; border: none; font: inherit; margin: 0; padding: 0"
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-31 01:23:38.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-31 01:23:38.000000000 +0300
@@ -113,9 +113,9 @@
_ -> Nothing)
potionGet exp args name s = (makePage s "Custom page" "" $
- tag "div" [("style", "border: 1px solid black; \
- \margin-bottom: 1em; padding: 1em; \
- \padding-bottom: 0; font-weight: bold")]
+ tag "div" [P "style" "border: 1px solid black; \
+ \margin-bottom: 1em; padding: 1em; \
+ \padding-bottom: 0; font-weight: bold"]
(rendered & saveLinks) & body, s) where
body = if (isComplete exp)
then (HTML $ head $ evalStateT (runExp env exp) s)
@@ -151,10 +151,10 @@
| i <- [0..25]])
& (catFor (filter ((==ty) . expType) $ getPotions s) $ \repl ->
para $ li $ linkExp repl $ renderExp repl id (error "some type"))
- , s) where linkExp new = tag "a" [("class", "editLink"),
- ("href", ?root ++ "potion?exp=" ++ show (subst (-1) new exp)
- ++ maybe "" ("&name="++) name)] .
- tag "span" [("class", "editPotion")]
+ , s) where linkExp new = tag "a" [P "class" "editLink",
+ P "href" $ ?root ++ "potion?exp=" ++ show (subst (-1) new exp)
+ ++ maybe "" ("&name="++) name] .
+ tag "span" [P "class" "editPotion"]
makeFun :: (?root :: String) => Request -> MyState -> (HTML, MyState)
makeFun msg s = let ?state = s; ?link = False; ?name=lookM msg "name" in
@@ -213,10 +213,10 @@
showTable :: (?root :: String) => Request -> MyState -> (HTML, MyState)
showTable req s = (
makePage s ("List of "++plural cat++" in the database") "" $
- tag "table" [("border","1")] $
+ tag "table" [P "border" "1"] $
(tag "tr" [] $ catFor cols $ \col -> tag "th" [] $ capitalize col) &
- (tag "tr" [] $ tag "td" [("colspan", show $ length cols),
- ("style", "text-align: center")] $
+ (tag "tr" [] $ tag "td" [P "colspan" $ length cols,
+ P "style" "text-align: center"] $
if not $ null items then new else
ital ("There are no "++plural cat++" in the database. ") &
mdot & new) &
@@ -282,7 +282,7 @@
main = stdHTTP [ debugFilter
, h (Prefix ()) () $ \(path::[String]) req ->
getTime >>= \time ->
- let ?time = time
+ let ?time = time; ?req = req
?root = concatMap (const "../") $ drop 1 path
in runServerParts [app] req
]
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-05-31 01:23:38.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-05-31 01:23:38.000000000 +0300
@@ -65,9 +65,9 @@
editLink :: (?link :: Bool, ?name :: Maybe String, ?root :: String,
ToHTML a) => (Exp -> Exp) -> Exp -> Type -> a -> HTML
editLink f old t s | not ?link = toHTML s | otherwise =
- flip (tag "a") s [("class", "editLink"), ("href",
+ flip (tag "a") s [P "class" "editLink", P "href" $
?root++"edit?exp="++(escape' $ show $ f $ Var (-1))++"&old="++(escape' $ show old)++"&type="++show t
- ++maybe "" ("&name="++) ?name)]
+ ++maybe "" ("&name="++) ?name]
renderMaybeExp (Just exp) cx ty = renderExp exp cx ty
renderMaybeExp Nothing cx ty = editLink cx (Var 0) ty $ bold $
@@ -104,7 +104,7 @@
renderExp' e@(Str _) cx ty = renderExp e cx ty
renderExp' e cx ty = surroundSpan (renderExp e cx ty)
-surroundSpan s = tag "span" [("class", if ?link then "editPotion" else "potion")] s
+surroundSpan s = tag "span" [P "class" $ if ?link then "editPotion" else "potion"] s
slices xs = map (\i -> (take i xs, xs !! i, drop (i+1) xs)) [0..length xs-1]
diff -rN -u old-fenserve/fendata/UI.hs new-fenserve/fendata/UI.hs
--- old-fenserve/fendata/UI.hs 2007-05-31 01:23:38.000000000 +0300
+++ new-fenserve/fendata/UI.hs 2007-05-31 01:23:38.000000000 +0300
@@ -34,12 +34,12 @@
\</style><title>Fenlight demo</title></head>"
makePage state title sidebar body = tag "body" [] $
- ( tag "div" [("class", "header")]
- ( etag "img" [("src", "http://iki.fi/tuukka/tmp/lantern-photo-75.jpeg"),
- ("class", "logo")]
+ ( tag "div" [P "class" "header"]
+ ( etag "img" [P "src" "http://iki.fi/tuukka/tmp/lantern-photo-75.jpeg",
+ P "class" "logo"]
, h1 ("Fenlight | ", title) )
- , tag "div" [("class", "main")]
- ( tag "div" [("class", "sidebar")]
+ , tag "div" [P "class" "main"]
+ ( tag "div" [P "class" "sidebar"]
( para "Welcome to Fenlight!", sidebar, hr
, catFor (stateSidebarPages state) $ \(fun, args) ->
let ?state=state; ?link=False; ?name=Nothing
@@ -51,8 +51,8 @@
, catFor (Map.keys $ stateSchema state) $ \cat ->
para $ qlink "table" [P "cat" cat] ("New ", cat, " view")
, para $ link (?root++"addCategory") "Add category" )
- , tag "div" [("class", "content")] body )
- , tag "div" [("class", "footer")]
+ , tag "div" [P "class" "content"] body )
+ , tag "div" [P "class" "footer"]
( "Fenlight (c) 2007 by Benja Fallenstein and Tuukka Hastrup. "
, link "http://www.flickr.com/photo_zoom.gne?id=244815014&size=sq" "Logo"
, " (c) 2006 by "
diff -rN -u old-fenserve/fendata/Utils.hs new-fenserve/fendata/Utils.hs
--- old-fenserve/fendata/Utils.hs 2007-05-31 01:23:38.000000000 +0300
+++ new-fenserve/fendata/Utils.hs 2007-05-31 01:23:38.000000000 +0300
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -fglasgow-exts #-}
module Utils where
@@ -9,11 +9,6 @@
import Data.List (intersperse)
-class ToString a where toString :: a -> String
-instance ToString String where toString = id
-instance Show a => ToString a where toString = show
-
-
for :: [a] -> (a -> b) -> [b]
for = flip map
@@ -25,8 +20,6 @@
escapeMore '[' = "%5b"; escapeMore ']' = "%5d";
escapeMore '&' = "%26"; escapeMore c = [c]
-data Param key = forall value. ToString value => P key value
-
qlink path params = link $ ?root ++ path ++ "?" ++ concatFor params
(\(P k v) -> k++"="++escape' (toString v))
More information about the Fencommits
mailing list