[Fencommits] fenserve: start working on a library abstracting over common HTML patterns
Benja Fallenstein
benja.fallenstein at gmail.com
Wed May 23 20:39:49 EEST 2007
Wed May 23 20:39:12 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* start working on a library abstracting over common HTML patterns
diff -rN -u old-fenserve/fendata/HTML.hs new-fenserve/fendata/HTML.hs
--- old-fenserve/fendata/HTML.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/HTML.hs 2007-05-23 20:39:48.000000000 +0300
@@ -0,0 +1,70 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+module HTML where
+
+newtype HTML = HTML String deriving (Read, Show, Eq, Ord)
+
+class ToHTML a where
+ toHTML :: a -> HTML
+
+fromHTML (HTML s) = s
+
+html :: ToHTML a => a -> String
+html = fromHTML . toHTML
+
+infixr 4 +++
+
+(+++) :: (ToHTML a, ToHTML b) => a -> b -> HTML
+x +++ y = HTML (html x ++ html y)
+
+cat :: ToHTML a => [a] -> HTML
+cat = HTML . concat . map (fromHTML . toHTML)
+
+catMap :: ToHTML b => (a -> b) -> [a] -> HTML
+catMap f = HTML . concatMap (html . f)
+
+catFor :: ToHTML b => [a] -> (a -> b) -> HTML
+catFor = flip catMap
+
+instance ToHTML HTML where
+ toHTML = id
+
+instance ToHTML String where
+ toHTML = HTML . quote
+
+quote = concatMap quoteChar
+quoteBr = concatMap (\c -> case c of '\n' -> "<br>"; _ -> quoteChar c)
+quoteP = 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+++"'>"
+
+etag :: String -> [(String,String)] -> HTML
+etag name attrs = "<"+++name+++a+++">"
+ where a = catFor attrs $ \(a,v) -> " "+++a+++"='"+++v+++"'>"
+
+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
+
+link href = tag "a" [("href", href)]
+
+formG href = tag "form" [("action", href), ("method", "GET")]
+formP href = tag "form" [("action", href), ("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)]
+
+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
+
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-23 20:39:48.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-23 20:39:48.000000000 +0300
@@ -1,5 +1,7 @@
{-# OPTIONS_GHC -fglasgow-exts #-}
+import HTML
+
import HAppS hiding (Body, getPath)
import Control.Monad.State
import Data.Generics (Typeable, Data, everywhere, mkT)
@@ -65,7 +67,7 @@
getPotions :: MyState -> [Exp]
getPotions s = map f (Map.toList $ statePotions s)
- ++ [HTML []]
+ ++ [Concat []]
++ concatFor (Map.toList $ stateSchema s) (\(cat,fs) ->
Call (show $ CatFun cat) []
: map (\f -> Call (show $ FieldFun cat f) [Nothing]) fs) where
@@ -74,14 +76,14 @@
data Exp = Call String [Maybe Exp]
| Var Int
| Forall Int Exp Exp
- | HTML [Maybe Exp]
+ | Concat [Maybe Exp]
| Str String
deriving (Read, Show, Typeable, Data)
expType (Call fun _) = funType $ readFun ?state fun
expType (Var _) = error "no type inference yet"
expType (Forall _ _ _) = string
-expType (HTML _) = string
+expType (Concat _) = string
expType (Str _) = string
editLink :: (?link :: Bool) => (Exp -> Exp) -> Exp -> Type -> String -> String
@@ -108,7 +110,7 @@
++ "<blockquote>\n" ++ renderExp body (\e -> cx $ Forall i exp e) string
++ "</blockquote>"
renderExp (Str s) cx _ = "<small>" ++ quoteP s ++ "</small>"
-renderExp exp@(HTML exps) cx _ = "<p>" ++ concatMap (\(xs,x,xs') -> renderMaybeExp x (\e -> cx (HTML (xs ++ [Just e] ++ xs'))) string) (slices exps) ++ if ?link then "<p>" ++ editLink cx exp string "[edit]" else ""
+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' e@(Str _) cx ty = renderExp e cx ty
renderExp' e cx ty = surround (renderExp e cx ty)
@@ -117,20 +119,13 @@
slices xs = map (\i -> (take i xs, xs !! i, drop (i+1) xs)) [0..length xs-1]
-quote = concatMap quoteChar
-quoteBr = concatMap (\c -> case c of '\n' -> "<br>"; _ -> quoteChar c)
-quoteP = concatMap (\c -> case c of '\n' -> "<p>"; _ -> quoteChar c)
-
-quoteChar c = case c of '<' -> "<"; '"' -> """; '\'' -> "'"
- '&' -> "&"; _ -> [c]
-
renderVar i = "<i>" ++ [toEnum (fromEnum 'a' + i)] ++ "</i>"
isComplete :: Exp -> Bool
isComplete (Call _ args) = all (maybe False isComplete) args
isComplete (Forall _ exp body) = isComplete exp && isComplete body
isComplete (Var _) = True
-isComplete (HTML exps) = all (maybe False isComplete) exps
+isComplete (Concat exps) = all (maybe False isComplete) exps
isComplete (Str _) = True
type Env = Map Int Value
@@ -147,8 +142,8 @@
runExp (Map.insert v x env) body
return $ concat rs
runExp env (Var i) = return $ env Map.! i
-runExp env (HTML exps) = do rs <- mapM (\(Just e) -> runExp env e) exps
- return $ concat rs
+runExp env (Concat exps) = do rs <- mapM (\(Just e) -> runExp env e) exps
+ return $ concat rs
runExp _ (Str s) = return s
runFun (Fun _ _ body) args =
@@ -199,13 +194,13 @@
])
potion = Forall 0 (Call (show $ CatFun "post") []) $
- HTML (map Just [Str "<h2>", Call (show $ FieldFun "post" "title") v, Str "</h2>",
+ Concat (map Just [Str "<h2>", Call (show $ FieldFun "post" "title") v, Str "</h2>",
Str "\n<p>Author: ", Call (show $ FieldFun "post" "author") v,
Str "\n<p>", Call (show $ FieldFun "post" "body") v,
Str "\n<hr>"])
where v = [Just $ Var 0]
-addPostForm = HTML $ map Just [Str "<h2>Add entry</h2>\n\
+addPostForm = Concat $ map Just [Str "<h2>Add entry</h2>\n\
\<form action=/potion/addPost method=post>\n\
\<input type=hidden name=count value=3>\n\
\Title: <input name=arg1><br>\n\
@@ -332,7 +327,7 @@
xs -> ("Wrong number of results: "++show xs, s)
edit :: (Exp,Exp,Type) -> MyState -> (String, MyState)
-edit (exp,old@(HTML olds),ty) s = let ?state = s; ?link = False in
+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) ++
@@ -369,10 +364,10 @@
, s) where
escapeMore '[' = "%5b"; escapeMore ']' = "%5d"; escapeMore c = [c]
Just exp = fmap read $ lookM msg "exp"
- Just (HTML olds) = fmap read $ lookM msg "old"
+ Just (Concat olds) = fmap read $ lookM msg "old"
Just tmp = lookM msg "template"
exps = filter (\e -> case e of Just (Str _) -> False; _ -> True) olds
- new = HTML $ f tmp
+ new = Concat $ f tmp
f ('$':c:cs)
| i < length exps = Just (Str "") : (exps !! i) : f cs
| otherwise = Just (Str "") : Nothing : f cs
More information about the Fencommits
mailing list