[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 '<' -> "&lt;"; '"' -> "&quot;"; '\'' -> "&apos;"
                         '&' -> "&amp;"; _ -> [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