[Fencommits] fenserve: more refactoring
Benja Fallenstein
benja.fallenstein at gmail.com
Thu May 31 12:04:52 EEST 2007
Thu May 31 03:04:29 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* more refactoring
diff -rN -u old-fenserve/fendata/HTML.hs new-fenserve/fendata/HTML.hs
--- old-fenserve/fendata/HTML.hs 2007-05-31 12:04:51.000000000 +0300
+++ new-fenserve/fendata/HTML.hs 2007-05-31 12:04:51.000000000 +0300
@@ -36,6 +36,9 @@
catFor :: ToHTML b => [a] -> (a -> b) -> HTML
catFor = flip catMap
+hif :: Bool -> HTML -> HTML
+hif b x = if b then x else HTML ""
+
instance ToHTML HTML where
toHTML = id
@@ -69,15 +72,16 @@
'&' -> "&"; _ -> [c]
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 attrs content = h "<" & name & a & h ">" & content
+ & h "</" & name & h ">" where
+ a = catFor attrs $ \(P a v) -> " " & a & h "='" & toString v & h "'"
+ h = HTML
tag' name = tag name []
etag :: String -> [Param String] -> HTML
-etag name attrs = HTML "<" & name & a & HTML ">"
- where a = catFor attrs $ \(P a v) -> " " & a & HTML "='" & toString v & HTML "'"
+etag name attrs = HTML "<" & name & a & HTML ">" where
+ a = catFor attrs $ \(P a v) -> " " & a & HTML "='" & toString v & HTML "'"
style s = tag "span" [P "style" s]
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-31 12:04:51.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-31 12:04:51.000000000 +0300
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction #-}
import HTML
import Potions
@@ -79,20 +79,25 @@
f x = x
+evaluate x = System.IO.Unsafe.unsafePerformIO $ Control.Exception.catch (Control.Exception.evaluate (length (show x) `seq` Right x)) (\e -> return $ Left e)
+
--run :: (a -> MyState -> (String, MyState)) -> a -> blah
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
+ state <- get
+ case evaluate (f x state) of
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
+ state <- get
+ case evaluate (f x state) of
Right (s, state') -> do put state'; respond (s, html $ link s "link")
Left e -> respond $ ("", "Internal server error: " ++ show e)
+
+runGet page = ok $ \() () -> respond $ case evaluate (html $ header & page) of
+ Right s -> s; Left e -> "Internal server error: " ++ show e
-potionPage fun args name s = (makePage s title expandLink body, s) where
+potionPage fun args name s = (makePage title expandLink body, s) where
exp = Call fun (map (Just . Str) $ args)
title = let ?state=s; ?link=False; ?name=name in renderExp exp id string
env = Map.fromList $ zip [0..length args-1] args
@@ -112,7 +117,7 @@
_ -> Nothing)
_ -> Nothing)
-potionGet exp args name s = (makePage s "Custom page" "" $
+potionGet exp args name s = (makePage "Custom page" "" $
tag "div" [P "style" "border: 1px solid black; \
\margin-bottom: 1em; padding: 1em; \
\padding-bottom: 0; font-weight: bold"]
@@ -156,14 +161,13 @@
++ 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
- (para ("Save '"&renderExp' exp id (error "some type")&"' as the "
- & "following potion (" & code "$(cat)" & ", where 'cat' is \
- \a category name, marks a hole):")
- & formP (?root++"addpotion") (para (textarea "template" 3 80 "")
- & para (submit "Save") & hidden "exp" (show exp)), s)
- where Just exp = fmap read $ lookM msg "exp"
+makeFun = let ?link = False; ?name = lookIM "name" in
+ ( para ( "Save '", renderExp' (lookR "exp") id (error "some type"), "' "
+ , "as the following potion (", code "$(cat)", ", where 'cat' is "
+ , "a category name, marks a hole):" )
+ , formP (?root++"addpotion")
+ ( para ( textarea "template" 3 80 "" )
+ , para ( submit "Save", channel ["exp"] ) ) )
editTemplate :: Request -> MyState -> (String, MyState)
editTemplate msg s =
@@ -210,35 +214,33 @@
s' = s { stateSidebarPages = stateSidebarPages s ++ [page] }
Just page@(fn,args) = fmap read $ lookM msg "page"
-showTable :: (?root :: String) => Request -> MyState -> (HTML, MyState)
-showTable req s = (
- makePage s ("List of "++plural cat++" in the database") "" $
- tag "table" [P "border" "1"] $
- (tag "tr" [] $ catFor cols $ \col -> tag "th" [] $ capitalize col) &
- (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) &
- (catFor (Map.toList $ stateItems s) $ \(id, Item fields cats) ->
- if cat `Set.member` cats then tag "tr" [] $
- catFor cols $ \col -> tag "td" [] $
- qlink ("item/"++show id) [P "returnTo" "table"] $ fields Map.! col
- else HTML ""),
- s) where new = formP (?root++"newItem") $ foldl1 (&)
- [ hidden "returnTo" "table"
- , hidden "cat" cat
- , button $ bold ("[New "&cat&"]") ]
- cat = fromMaybe (head $ Map.keys $ stateSchema s) (lookM req "cat")
- items = flip filter (Map.toList $ stateItems s) $
- \(_, Item _ cats) -> cat `Set.member` cats
- cols = flip fromMaybe (fmap read $ lookM req "cols") $
- take 1 $ stateSchema s Map.! cat
+showTable = makePage ("List of "++plural cat++" in the database") ""
+ ( tag "table" [P "border" "1"]
+ ( tag "tr" [] $ catFor cols $ \col -> tag "th" [] $ capitalize col)
+ , tag "tr" [] $ tag "td" [P "colspan" $ length cols,
+ P "style" "text-align: center"]
+ ( hif (null items) $ ital ( "There are no ", plural cat,
+ " in the database. " ) & mdot
+ , formP (?root++"newItem")
+ ( hidden "returnTo" "table"
+ , hidden "cat" cat
+ , button $ bold ("[New ", cat, "]") ) )
+
+ , catFor (Map.toList allItems) $ \(id, Item fields cats) ->
+ if cat `Set.member` cats then tag "tr" [] $
+ catFor cols $ \col -> tag "td" [] $
+ qlink ("item/"++show id) [P "returnTo" "table"]
+ (fields Map.! col)
+ else HTML "" )
+ where cat = lookI "cat" (head $ Map.keys schema)
+ items = flip filter (Map.toList allItems) $
+ \(_, Item _ cats) -> cat `Set.member` cats
+ cols = lookRD "cols" (take 1 $ schema Map.! cat)
-showItem :: (?root :: String) =>
+showItem :: (?root :: String, ?state :: MyState) =>
String -> Request -> MyState -> (HTML, MyState)
showItem item req s = let Item fields cats = stateItems s Map.! read item in (
- makePage s "Item editor" "" $
+ makePage "Item editor" "" $
formP "" . ((returnTo&buttons&hr)&) . (&hr&buttons) .
catFor (Set.toList cats) $ \cat -> let cfs = stateSchema s Map.! cat in
(h3 (capitalize cat) &) . para
@@ -299,8 +301,8 @@
read $ fromJust $ lookM req "type",
lookM req "name")
, h ["editTemplate"] GET $ seeOther $ \() -> runRedirect editTemplate
- , h ["makefun"] GET $ ok $ \() -> run makeFun
- , h ["table"] GET $ ok $ \() -> run showTable
+ , h ["makefun"] GET $ runGet makeFun
+ , h ["table"] GET $ runGet showTable
, h (Prefix ["item"]) GET $ ok $ \[item] -> run (showItem item)
, h (Prefix ["item"]) POST $ seeOther $ \[item] ->
runRedirect (updateItem item)
diff -rN -u old-fenserve/fendata/PotionTypes.hs new-fenserve/fendata/PotionTypes.hs
--- old-fenserve/fendata/PotionTypes.hs 2007-05-31 12:04:51.000000000 +0300
+++ new-fenserve/fendata/PotionTypes.hs 2007-05-31 12:04:51.000000000 +0300
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction #-}
module PotionTypes where
@@ -62,3 +62,6 @@
u_potions f s = s { statePotions = f (statePotions s) }
u_sidebarPages f s = s { stateSidebarPages = f (stateSidebarPages s) }
+schema = stateSchema ?state
+allItems = stateItems ?state
+allPotions = statePotions ?state
diff -rN -u old-fenserve/fendata/UI.hs new-fenserve/fendata/UI.hs
--- old-fenserve/fendata/UI.hs 2007-05-31 12:04:51.000000000 +0300
+++ new-fenserve/fendata/UI.hs 2007-05-31 12:04:51.000000000 +0300
@@ -33,7 +33,7 @@
\form { display: inline } \
\</style><title>Fenlight demo</title></head>"
-makePage state title sidebar body = tag "body" [] $
+makePage title sidebar body = tag "body" [] $
( tag "div" [P "class" "header"]
( etag "img" [P "src" "http://iki.fi/tuukka/tmp/lantern-photo-75.jpeg",
P "class" "logo"]
@@ -41,14 +41,14 @@
, 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
+ , catFor (stateSidebarPages ?state) $ \(fun, args) ->
+ let ?link=False; ?name=Nothing
in let exp = Call fun (map (Just . Str) args)
uri = ?root++"potion/"++fun++concat ["/"++a | a <- args]
in para $ bold $ link uri $ renderExp exp id string
, hr
, para $ qlink "potion" [P "exp" $ Block []] "New page"
- , catFor (Map.keys $ stateSchema state) $ \cat ->
+ , catFor (Map.keys schema) $ \cat ->
para $ qlink "table" [P "cat" cat] ("New ", cat, " view")
, para $ link (?root++"addCategory") "Add category" )
, tag "div" [P "class" "content"] body )
diff -rN -u old-fenserve/fendata/Utils.hs new-fenserve/fendata/Utils.hs
--- old-fenserve/fendata/Utils.hs 2007-05-31 12:04:51.000000000 +0300
+++ new-fenserve/fendata/Utils.hs 2007-05-31 12:04:51.000000000 +0300
@@ -26,8 +26,14 @@
k ++ "=" ++ escape' (toString v))
+lookIM :: (?req :: Request, Monad m) => String -> m String
+lookIM field = lookM ?req field
+
lookI :: (?req :: Request) => String -> String -> String
-lookI field deflt = fromMaybe deflt (lookM ?req field)
+lookI field deflt = fromMaybe deflt $ lookIM field
+
+lookR field = read $ fromMaybe (error $ "missing field: "++field) $ lookIM field
+lookRD field deflt = fromMaybe deflt $ fmap read $ lookIM field
lookE field = lookI field ""
More information about the Fencommits
mailing list