[Fencommits] fenserve: split into several modules
Benja Fallenstein
benja.fallenstein at gmail.com
Fri May 25 17:13:21 EEST 2007
Fri May 25 17:12:36 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* split into several modules
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-25 17:13:21.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-25 17:13:21.000000000 +0300
@@ -1,202 +1,24 @@
{-# OPTIONS_GHC -fglasgow-exts #-}
import HTML
+import Potions
+import PotionTypes
+import UI
+import Utils
import HAppS hiding (Body, getPath)
import Control.Monad.State
import Data.Generics (Typeable, Data, everywhere, mkT)
import Data.Binary hiding (get,put)
-import Data.List (intersperse)
import Data.Maybe (fromJust, fromMaybe, isJust)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
-import Data.Char (toUpper, toLower)
import qualified System.IO.Unsafe
import qualified Control.Exception
-header = HTML "<head><style>a.editLink { text-decoration: none; color: inherit} \
- \button {\
- \ cursor: pointer; background: none; border: none; \
- \ font: inherit; margin: 0; padding: 0 } \
- \.potion, .editPotion {\
- \ border: dashed black 1px; padding: 2px; \
- \ margin: 2px; line-height: 90% } \
- \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 } \
- \.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} \
- \.header {border: 1px solid white; margin-bottom: 2em; clear: both} \
- \h1 {border-bottom: 1px solid black} \
- \body {margin-left: 100px; margin-right: 100px} \
- \.content {float: right; width: 80% } \
- \.sidebar {float: left; width: 15%; font-size: small } \
- \h1, h2, h3, h4, h5, h6 { font-family: sans-serif } \
- \</style><title>Fendata demo</title></head>"
-
-type Id = Int
-
-data Item = Item { itemFields :: Map String String, itemCategories :: Set String }
- deriving (Read, Show, Typeable, Data)
-
-data Type = Type { typeQuestion :: String }
- deriving (Read, Show, Typeable, Data, Eq, Ord)
-
-catType name = Type ("which " ++ name ++ "?")
-string = Type "which text?"
-action = Type "Do what?"
-
-data Fun = Fun [Type] [HTML] Exp
- | FieldFun String String
- | CatFun String
- | AddItemFun String [String]
- deriving (Read, Show, Typeable, Data, Eq, Ord)
-
-readFun :: MyState -> String -> Fun
-readFun s n | ((r,""):_) <- reads n = r
- | otherwise = statePotions s Map.! n
-
-funType (Fun _ _ exp) = expType exp
-funType (FieldFun _ _) = string
-funType (CatFun cat) = catType cat
-funType (AddItemFun _ _) = action
-
-funTypes (Fun ts _ _) = ts
-funTypes (FieldFun cat _) = [catType cat]
-funTypes (CatFun _) = []
-funTypes (AddItemFun _ fs) = map (const string) fs
-
-funParts (Fun _ ps _) = ps
-funParts (FieldFun _ name) = map toHTML ["the "++name++" of ", ""]
-funParts (CatFun cat) = map toHTML ["all 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++"."]
-
-for :: [a] -> (a -> b) -> [b]
-for = flip map
-
-concatFor :: [a] -> (a -> [b]) -> [b]
-concatFor = flip concatMap
-
-getPotions :: MyState -> [Exp]
-getPotions s = map f (Map.toList $ statePotions s)
- ++ [Concat []]
- ++ concatFor (Map.toList $ stateSchema s) (\(cat,fs) ->
- Call (show $ CatFun cat) []
- : Forall (catType cat) 0 Nothing Nothing
- : map (\f -> Call (show $ FieldFun cat f) [Nothing]) fs) where
- f (n, Fun ts _ _) = Call n (replicate (length ts) Nothing)
-
-data Exp = Call String [Maybe Exp]
- | Var Int
- | Forall Type Int (Maybe Exp) (Maybe Exp)
- | Concat [Maybe Exp]
- | Str String
- deriving (Read, Show, Typeable, Data, Eq, Ord)
-
-expType (Call fun _) = funType $ readFun ?state fun
-expType (Var _) = error "no type inference yet"
-expType (Forall _ _ _ _) = string
-expType (Concat _) = string
-expType (Str _) = string
-
-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",
- ?root++"edit?exp="++(escape' $ show $ f $ Var (-1))++"&old="++(escape' $ show old)++"&type="++show t
- ++maybe "" ("&name="++) ?name)]
-
-renderMaybeExp (Just exp) cx ty = renderExp exp cx ty
-renderMaybeExp Nothing cx ty = editLink cx (Var 0) ty $ bold $
- "[" +++ typeQuestion ty +++ "]"
-
-renderMaybeExp' (Just exp) cx ty = renderExp' exp cx ty
-renderMaybeExp' Nothing cx ty = editLink cx (Var 0) ty $ surroundSpan $ bold $
- "[" +++ typeQuestion ty +++ "]"
-
-renderExp :: (?state :: MyState, ?link :: Bool, ?name :: Maybe String,
- ?root :: String) => 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)
-renderExp exp@(Var i) cx ty = editLink cx exp ty (renderVar i)
-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" (renderMaybeExp body (\e -> cx $ Forall t i exp (Just 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 = surroundSpan (renderExp e cx ty)
-
-surroundSpan s = tag "span" [("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]
-
-renderVar i = ital [toEnum (fromEnum 'a' + i) :: Char]
-
-isComplete :: Exp -> Bool
-isComplete (Call _ args) = all (maybe False isComplete) args
-isComplete (Forall _ _ exp body) = all (maybe False isComplete) [exp, body]
-isComplete (Var _) = True
-isComplete (Concat exps) = all (maybe False isComplete) exps
-isComplete (Str _) = True
-
-type Env = Map Int Value
-type Value = String
-
-runExp :: Env -> Exp -> StateT MyState [] Value
-runExp env (Call fname args) = do
- state <- get; let fn = readFun state fname
- vals <- mapM (runExp env . fromJust) args
- runFun fn vals
-runExp env (Forall _ v (Just exp) (Just body)) = do
- state <- get; let xs = evalStateT (runExp env exp) state
- rs <- forM xs $ \x -> runExp (Map.insert v x env) body
- return $ concat rs
-runExp env (Var i) = return $ fromMaybe ("0") $
- Map.lookup i env
-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 =
- runExp (Map.fromList [(i, args!!i) | i <- [0..length args-1]]) body
-runFun (FieldFun cat name) [item] = do
- state <- get
- return $ itemFields (stateItems state Map.! read item) Map.! name
-runFun (CatFun cat) [] = do
- state <- get
- msum [return $ show n | (n, Item _ cs) <- Map.toList (stateItems state), cat `Set.member` cs]
-runFun (AddItemFun cat fields) vals = do
- s <- get; let items = stateItems s
- let catFs = stateSchema s Map.! cat
- m = Map.fromList $ [(f,"") | f <- catFs] ++ zip fields vals
- item = Item m (Set.singleton cat)
- put s { stateItems = Map.insert (nextId items) item items }
- return "Done."
-
-nextId :: Map Id a -> Id
-nextId m = if Map.null m then 0 else fst (Map.findMax m) + 1
-
-data MyState = MyState { stateItems :: Map Id Item,
- stateSchema :: Map String [String],
- statePotions :: Map String Fun,
- stateSidebarPages :: [Exp] }
- deriving (Read, Show, Typeable, Data)
-
instance Binary MyState where
instance StartState MyState where
@@ -263,8 +85,8 @@
Just name = lookM req "field"
returnTo = fromMaybe ("item/"++item) (lookM req "returnTo")
-addCategory (c:cs) s = ("table",
- s { stateSchema = Map.insert (toLower c : cs) [] $ stateSchema s})
+addCategory name s = ("table",
+ s { stateSchema = Map.insert (uncapitalize name) [] $ stateSchema s})
expand s (Call n args) = case readFun s n of
Fun _ _ body -> Just
@@ -362,10 +184,6 @@
+++ para (submit "Save") +++ hidden "exp" (show exp)), s)
where Just exp = fmap read $ lookM msg "exp"
-escape' = concatMap escapeMore . escape where
- escapeMore '[' = "%5b"; escapeMore ']' = "%5d";
- escapeMore '&' = "%26"; escapeMore c = [c]
-
editTemplate :: Request -> MyState -> (String, MyState)
editTemplate msg s =
("potion?exp=" ++ escape' (show (subst (-1) new exp))
@@ -409,15 +227,6 @@
s' = s { stateSidebarPages = stateSidebarPages s ++ [read exp] }
Just exp = lookM msg "exp"
-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 -> (HTML, MyState)
showTable () s = (
let ?root="" in makePage s "List of items in the database" "" $
@@ -437,11 +246,6 @@
. mdotted . for (Map.keys $ stateSchema s) $ \cat ->
button' "cat" cat $ bold ("[New "+++cat+++"]")
-mdot = style "margin-left: 0.5em; margin-right: 0.5em; font-weight: bold" $
- HTML "·"
-
-mdotted = cat . intersperse (" "+++mdot+++" ")
-
showItem :: String -> Request -> MyState -> (HTML, MyState)
showItem item req s = let Item fields cats = stateItems s Map.! read item in (
let ?root = "../" in makePage s "Item editor" "" $
@@ -483,30 +287,6 @@
s' = s { stateItems = Map.delete id $ stateItems s }
Just id = fmap read $ lookM msg "item"
-makePage state title sidebar body =
- --(tag "title" [] title +++) .
- tag "body" [] $
- tag "div" [("class", "header")]
- (etag "img" [("src", "http://iki.fi/tuukka/tmp/lantern-photo-75.jpeg"),
- ("class", "logo")] +++
- h1 ("Fendata | " +++ title)) +++
- tag "div" [("class", "main")] (
- tag "div" [("class", "sidebar")] (
- para "Welcome to Fendata!" +++ sidebar +++ hr +++
- catFor (stateSidebarPages state) (\exp ->
- let ?state=state; ?link=False; ?name=Nothing
- in para $ bold $ link (?root++"potion?exp="++escape' (show exp)) $
- renderExp exp id string) +++ hr +++
- link (?root++"table") "List of items in the database") +++
- tag "div" [("class", "content")] body) +++
- tag "div" [("class", "footer")]
- ("Fendata (c) 2007 by Benja Fallenstein and Tuukka Hastrup. " +++
- link "http://www.flickr.com/photo_zoom.gne?id=244815014&size=sq" "Logo" +++
- " (c) 2006 by " +++ link "http://www.flickr.com/photos/44458147@N00/"
- "The G-tastic 7" +++ ". All content is licensed under the " +++
- link "http://creativecommons.org/licenses/by-sa/2.0/"
- "Creative Commons Attribution-ShareAlike 2.0 license" +++ ".")
-
main = stdHTTP [ debugFilter
, h ["potion"] GET $ ok $ \() -> run $
\(exp,args,name) s -> let ?root = "" in potionGet exp args name s
diff -rN -u old-fenserve/fendata/PotionTypes.hs new-fenserve/fendata/PotionTypes.hs
--- old-fenserve/fendata/PotionTypes.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/PotionTypes.hs 2007-05-25 17:13:21.000000000 +0300
@@ -0,0 +1,49 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+module PotionTypes where
+
+import HTML
+
+import Data.Generics (Typeable, Data)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+data Type = Type { typeQuestion :: String }
+ deriving (Read, Show, Typeable, Data, Eq, Ord)
+
+data Fun = Fun [Type] [HTML] Exp
+ | FieldFun String String
+ | CatFun String
+ | AddItemFun String [String]
+ deriving (Read, Show, Typeable, Data, Eq, Ord)
+
+data Exp = Call String [Maybe Exp]
+ | Var Int
+ | Forall Type Int (Maybe Exp) (Maybe Exp)
+ | Concat [Maybe Exp]
+ | Str String
+ deriving (Read, Show, Typeable, Data, Eq, Ord)
+
+
+type Env = Map Int Value
+type Value = String
+
+
+
+type Id = Int
+
+data Item = Item { itemFields :: Map String String, itemCategories :: Set String }
+ deriving (Read, Show, Typeable, Data)
+
+nextId :: Map Id a -> Id
+nextId m = if Map.null m then 0 else fst (Map.findMax m) + 1
+
+data MyState = MyState { stateItems :: Map Id Item,
+ stateSchema :: Map String [String],
+ statePotions :: Map String Fun,
+ stateSidebarPages :: [Exp] }
+ deriving (Read, Show, Typeable, Data)
+
+
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/Potions.hs 2007-05-25 17:13:21.000000000 +0300
@@ -0,0 +1,141 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+module Potions where
+
+import HTML
+import PotionTypes
+import Utils
+
+import Control.Monad.State
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (fromJust, fromMaybe, isJust)
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+catType name = Type ("which " ++ name ++ "?")
+string = Type "which text?"
+action = Type "Do what?"
+
+readFun :: MyState -> String -> Fun
+readFun s n | ((r,""):_) <- reads n = r
+ | otherwise = statePotions s Map.! n
+
+funType (Fun _ _ exp) = expType exp
+funType (FieldFun _ _) = string
+funType (CatFun cat) = catType cat
+funType (AddItemFun _ _) = action
+
+funTypes (Fun ts _ _) = ts
+funTypes (FieldFun cat _) = [catType cat]
+funTypes (CatFun _) = []
+funTypes (AddItemFun _ fs) = map (const string) fs
+
+funParts (Fun _ ps _) = ps
+funParts (FieldFun _ name) = map toHTML ["the "++name++" of ", ""]
+funParts (CatFun cat) = map toHTML ["all 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++"."]
+
+for :: [a] -> (a -> b) -> [b]
+for = flip map
+
+concatFor :: [a] -> (a -> [b]) -> [b]
+concatFor = flip concatMap
+
+getPotions :: MyState -> [Exp]
+getPotions s = map f (Map.toList $ statePotions s)
+ ++ [Concat []]
+ ++ concatFor (Map.toList $ stateSchema s) (\(cat,fs) ->
+ Call (show $ CatFun cat) []
+ : Forall (catType cat) 0 Nothing Nothing
+ : map (\f -> Call (show $ FieldFun cat f) [Nothing]) fs) where
+ f (n, Fun ts _ _) = Call n (replicate (length ts) Nothing)
+
+expType (Call fun _) = funType $ readFun ?state fun
+expType (Var _) = error "no type inference yet"
+expType (Forall _ _ _ _) = string
+expType (Concat _) = string
+expType (Str _) = string
+
+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",
+ ?root++"edit?exp="++(escape' $ show $ f $ Var (-1))++"&old="++(escape' $ show old)++"&type="++show t
+ ++maybe "" ("&name="++) ?name)]
+
+renderMaybeExp (Just exp) cx ty = renderExp exp cx ty
+renderMaybeExp Nothing cx ty = editLink cx (Var 0) ty $ bold $
+ "[" +++ typeQuestion ty +++ "]"
+
+renderMaybeExp' (Just exp) cx ty = renderExp' exp cx ty
+renderMaybeExp' Nothing cx ty = editLink cx (Var 0) ty $ surroundSpan $ bold $
+ "[" +++ typeQuestion ty +++ "]"
+
+renderExp :: (?state :: MyState, ?link :: Bool, ?name :: Maybe String,
+ ?root :: String) => 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)
+renderExp exp@(Var i) cx ty = editLink cx exp ty (renderVar i)
+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" (renderMaybeExp body (\e -> cx $ Forall t i exp (Just 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 = surroundSpan (renderExp e cx ty)
+
+surroundSpan s = tag "span" [("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]
+
+renderVar i = ital [toEnum (fromEnum 'a' + i) :: Char]
+
+isComplete :: Exp -> Bool
+isComplete (Call _ args) = all (maybe False isComplete) args
+isComplete (Forall _ _ exp body) = all (maybe False isComplete) [exp, body]
+isComplete (Var _) = True
+isComplete (Concat exps) = all (maybe False isComplete) exps
+isComplete (Str _) = True
+
+runExp :: Env -> Exp -> StateT MyState [] Value
+runExp env (Call fname args) = do
+ state <- get; let fn = readFun state fname
+ vals <- mapM (runExp env . fromJust) args
+ runFun fn vals
+runExp env (Forall _ v (Just exp) (Just body)) = do
+ state <- get; let xs = evalStateT (runExp env exp) state
+ rs <- forM xs $ \x -> runExp (Map.insert v x env) body
+ return $ concat rs
+runExp env (Var i) = return $ fromMaybe ("0") $
+ Map.lookup i env
+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 =
+ runExp (Map.fromList [(i, args!!i) | i <- [0..length args-1]]) body
+runFun (FieldFun cat name) [item] = do
+ state <- get
+ return $ itemFields (stateItems state Map.! read item) Map.! name
+runFun (CatFun cat) [] = do
+ state <- get
+ msum [return $ show n | (n, Item _ cs) <- Map.toList (stateItems state), cat `Set.member` cs]
+runFun (AddItemFun cat fields) vals = do
+ s <- get; let items = stateItems s
+ let catFs = stateSchema s Map.! cat
+ m = Map.fromList $ [(f,"") | f <- catFs] ++ zip fields vals
+ item = Item m (Set.singleton cat)
+ put s { stateItems = Map.insert (nextId items) item items }
+ return "Done."
+
+
diff -rN -u old-fenserve/fendata/UI.hs new-fenserve/fendata/UI.hs
--- old-fenserve/fendata/UI.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/UI.hs 2007-05-25 17:13:21.000000000 +0300
@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+module UI where
+
+import HTML
+import Potions
+import PotionTypes
+import Utils
+
+header = HTML "<head><style>a.editLink { text-decoration: none; color: inherit} \
+ \button {\
+ \ cursor: pointer; background: none; border: none; \
+ \ font: inherit; margin: 0; padding: 0 } \
+ \.potion, .editPotion {\
+ \ border: dashed black 1px; padding: 2px; \
+ \ margin: 2px; line-height: 90% } \
+ \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 } \
+ \.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} \
+ \.header {border: 1px solid white; margin-bottom: 2em; clear: both} \
+ \h1 {border-bottom: 1px solid black} \
+ \body {margin-left: 100px; margin-right: 100px} \
+ \.content {float: right; width: 80% } \
+ \.sidebar {float: left; width: 15%; font-size: small } \
+ \h1, h2, h3, h4, h5, h6 { font-family: sans-serif } \
+ \</style><title>Fendata demo</title></head>"
+
+makePage state title sidebar body =
+ --(tag "title" [] title +++) .
+ tag "body" [] $
+ tag "div" [("class", "header")]
+ (etag "img" [("src", "http://iki.fi/tuukka/tmp/lantern-photo-75.jpeg"),
+ ("class", "logo")] +++
+ h1 ("Fendata | " +++ title)) +++
+ tag "div" [("class", "main")] (
+ tag "div" [("class", "sidebar")] (
+ para "Welcome to Fendata!" +++ sidebar +++ hr +++
+ catFor (stateSidebarPages state) (\exp ->
+ let ?state=state; ?link=False; ?name=Nothing
+ in para $ bold $ link (?root++"potion?exp="++escape' (show exp)) $
+ renderExp exp id string) +++ hr +++
+ link (?root++"table") "List of items in the database") +++
+ tag "div" [("class", "content")] body) +++
+ tag "div" [("class", "footer")]
+ ("Fendata (c) 2007 by Benja Fallenstein and Tuukka Hastrup. " +++
+ link "http://www.flickr.com/photo_zoom.gne?id=244815014&size=sq" "Logo" +++
+ " (c) 2006 by " +++ link "http://www.flickr.com/photos/44458147@N00/"
+ "The G-tastic 7" +++ ". All content is licensed under the " +++
+ link "http://creativecommons.org/licenses/by-sa/2.0/"
+ "Creative Commons Attribution-ShareAlike 2.0 license" +++ ".")
+
+
diff -rN -u old-fenserve/fendata/Utils.hs new-fenserve/fendata/Utils.hs
--- old-fenserve/fendata/Utils.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/Utils.hs 2007-05-25 17:13:21.000000000 +0300
@@ -0,0 +1,32 @@
+
+module Utils where
+
+import HAppS
+import HTML
+
+import Data.Char (toUpper, toLower)
+import Data.List (intersperse)
+
+
+escape' = concatMap escapeMore . escape where
+ escapeMore '[' = "%5b"; escapeMore ']' = "%5d";
+ escapeMore '&' = "%26"; escapeMore c = [c]
+
+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 "" = ""
+
+uncapitalize (c:cs) = toLower c : cs
+uncapitalize "" = ""
+
+mdot = style "margin-left: 0.5em; margin-right: 0.5em; font-weight: bold" $
+ HTML "·"
+
+mdotted = cat . intersperse (" "+++mdot+++" ")
+
+
More information about the Fencommits
mailing list