[Fencommits] fenserve: shorten some too long lines
Tuukka Hastrup
Tuukka.Hastrup at iki.fi
Thu May 31 21:08:55 EEST 2007
Thu May 31 21:08:14 EEST 2007 Tuukka Hastrup <Tuukka.Hastrup at iki.fi>
* shorten some too long lines
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-05-31 21:08:55.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-05-31 21:08:55.000000000 +0300
@@ -60,7 +60,8 @@
, formP ""
( "Field: " & textfield "name" ""
, channel ["category", "item"]
- , hidden "returnTo" $ fromMaybe ("item/"++lookE "item") (lookIM "returnTo")
+ , hidden "returnTo" $ fromMaybe ("item/"++lookE "item")
+ (lookIM "returnTo")
, submit "Submit" ) )
addFieldPost = runPost (lookE "returnTo")
@@ -82,8 +83,8 @@
returnTo = fromMaybe ("item/"++item) (lookM req "returnTo")-}
addCategory req s = ("table",
- s { stateSchema = Map.insert (uncapitalize name) ["name"] $ stateSchema s}) where
- Just name = lookM req "name"
+ s { stateSchema = Map.insert (uncapitalize name) ["name"] $ stateSchema s})
+ where Just name = lookM req "name"
subst :: Int -> Exp -> Exp -> Exp
subst i repl e = everywhere (mkT f) e where
@@ -92,7 +93,9 @@
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)
+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
@@ -123,11 +126,13 @@
then (HTML $ head $ evalStateT (runExp env exp) s)
else toHTML "(Incomplete expression.)"
Fun _ _ funBody = readFun s fun
- expandLink = (para $ qlink "potion" [P "exp" funBody, P "name" fun] "[edit page]")
- & maybe (HTML "") (\page ->
+ expandLink = para (qlink "potion" [P "exp" funBody, P "name" fun]
+ "[edit page]")
+ & maybe (HTML "") (\page ->
(if page `elem` stateSidebarPages s then HTML "" else
- para $ formP (?root++"addToSidebar") (hidden "page" (show page)
- & button "[add to sidebar]")))
+ para $ formP (?root++"addToSidebar")
+ (hidden "page" (show page)
+ & button "[add to sidebar]")))
(case exp of
Call fun args -> fmap (\a -> (fun,a)) $
sequence args >>=
@@ -169,15 +174,18 @@
edit (exp,old@(Inline olds),ty,name) s = editText exp old olds ty name s
edit (exp,old,ty,name) s = let ?state = s; ?link = False; ?name=name in
(para ("Select something to replace '" & renderExp' old id ty & "' "
- & "with.") & hr
- & para ("Variables: " & cat [linkExp (Var i) (renderVar i)&" "
- | i <- [0..25]])
- & (catFor (filter ((==ty) . expType) $ getPotions s) $ \repl ->
+ & "with.")
+ & hr
+ & para ("Variables: " & cat [linkExp (Var i) (renderVar i) & " "
+ | 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" [P "class" "editLink",
- P "href" $ ?root ++ "potion?exp=" ++ show (subst (-1) new exp)
- ++ maybe "" ("&name="++) name] .
- tag "span" [P "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 = let ?link = False; ?name = lookIM "name" in
( para ( "Save '", renderExp' (lookR "exp") id (error "some type"), "' "
@@ -272,8 +280,8 @@
else textfield field) (fields Map.! field)
& br,
s) where uri = fromMaybe "" (lookM req "returnTo")
- returnTo = flip (maybe $ HTML "") (lookM req "returnTo") $ \uri -> HTML $
- "<input type=hidden name=returnTo value='"++html(escape uri)++"'>"
+ returnTo = flip (maybe $ HTML "") (lookM req "returnTo") $ \uri ->
+ hidden "returnTo" uri
buttons = HTML $ "<p><button>[Save]</button> "++html mdot++" "++
"<a href='"++ ?root++html uri++"'>[Cancel]</a></form>"
@@ -309,33 +317,36 @@
app :: (?root :: String, ?time :: Int64, ?req :: Request, ?state :: MyState)
=> ServerPart (Ev MyState ev) Request IO Result
-app = multi [ h ["potion"] GET $ ok $ \() -> run $
- \req s -> potionGet (read $ fromJust $ lookM req "exp") (readArgs req) (lookM req "name") s
- , h (Prefix ["potion"]) GET $ ok $ \(fun:args) -> run $
- \req s -> potionPage fun args (lookM req "name") s
- , h ["edit"] GET $ ok $ \() -> run $ \req ->
- edit (read $ fromJust $ lookM req "exp",
- read $ fromJust $ lookM req "old",
- read $ fromJust $ lookM req "type",
- lookM req "name")
- , h ["editTemplate"] GET $ seeOther $ \() -> runRedirect editTemplate
- , 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)
- , h ["newItem"] POST $ seeOther $ \() -> runRedirect newItem
- , h ["delItem"] POST $ seeOther $ \() -> runRedirect delItem
+app = multi
+ [ h ["potion"] GET $ ok $ \() -> run $
+ \req s -> potionGet (read $ fromJust $ lookM req "exp")
+ (readArgs req) (lookM req "name") s
+ , h (Prefix ["potion"]) GET $ ok $ \(fun:args) -> run $
+ \req s -> potionPage fun args (lookM req "name") s
+ , h ["edit"] GET $ ok $ \() -> run $ \req ->
+ edit (read $ fromJust $ lookM req "exp",
+ read $ fromJust $ lookM req "old",
+ read $ fromJust $ lookM req "type",
+ lookM req "name")
+ , h ["editTemplate"] GET $ seeOther $ \() -> runRedirect editTemplate
+ , 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)
+ , h ["newItem"] POST $ seeOther $ \() -> runRedirect newItem
+ , h ["delItem"] POST $ seeOther $ \() -> runRedirect delItem
- , h [""] GET $ seeOther $ \() -> runRedirect $ \() s -> ("potion/" ++ (case head $ stateSidebarPages s of (fn,args) -> fn ++ concat ["/"++a | a <- args]), s)
- , h ["addField"] GET $ addFieldGet
- , h ["addField"] POST $ addFieldPost
- , h ["addCategory"] GET $ runGet
- ( h2 "Add category"
- , formP "" ( "Name: " & textfield "name" ""
- , submit "Submit" ) )
- , h ["addCategory"] POST $ seeOther $ \() -> runRedirect addCategory
- , h ["addpotion"] POST $ seeOther $ \() -> runRedirect addPotion
- , h ["addToSidebar"] POST $ seeOther $ \() -> runRedirect addToSidebar
- ]
-
+ , h [""] GET $ seeOther $ \() -> runRedirect $ \() s ->
+ ("potion/" ++ (case head $ stateSidebarPages s of
+ (fn,args) -> fn ++ concat ["/"++a | a <- args]), s)
+ , h ["addField"] GET $ addFieldGet
+ , h ["addField"] POST $ addFieldPost
+ , h ["addCategory"] GET $ runGet
+ ( h2 "Add category"
+ , formP "" ( "Name: " & textfield "name" ""
+ , submit "Submit" ) )
+ , h ["addCategory"] POST $ seeOther $ \() -> runRedirect addCategory
+ , h ["addpotion"] POST $ seeOther $ \() -> runRedirect addPotion
+ , h ["addToSidebar"] POST $ seeOther $ \() -> runRedirect addToSidebar
+ ]
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-05-31 21:08:55.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-05-31 21:08:55.000000000 +0300
@@ -40,13 +40,14 @@
AllItems cat
: NewItemButton cat
: Forall cat 0 Nothing (Block [])
- : concatFor fs (\f -> [ Field cat f Nothing
- , SortByField cat f 1 Nothing
- , SortByField cat f (-1) Nothing
- , FilterByField cat f (-1) Nothing (Inline [])
- , FilterByField cat f 0 Nothing (Inline [])
- , FilterByField cat f 1 Nothing (Inline [])
- ])) where
+ : concatFor fs (\f ->
+ [ Field cat f Nothing
+ , SortByField cat f 1 Nothing
+ , SortByField cat f (-1) Nothing
+ , FilterByField cat f (-1) Nothing (Inline [])
+ , FilterByField cat f 0 Nothing (Inline [])
+ , FilterByField cat f 1 Nothing (Inline [])
+ ])) where
f (n, Fun ts _ _) = Call n (replicate (length ts) Nothing)
expType (Call fun _) = funType $ readFun ?state fun
@@ -66,8 +67,9 @@
ToHTML a) => (Exp -> Exp) -> Exp -> Type -> a -> HTML
editLink f old t s | not ?link = toHTML s | otherwise =
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]
+ ?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 $
@@ -79,32 +81,57 @@
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
+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)
f ts xs [] n = f ts xs [Just $ Str "0"] n
-renderExp e0@(Field cat field exp) cx ty = editLink cx e0 ty ("the " & field & " of ") & renderMaybeExp' exp (\e -> cx $ Field cat field $ Just e) (catType cat) where
-renderExp e0@(AllItems cat) cx ty = editLink cx e0 ty ("all the "++cat++"s in the system")
-renderExp e0@(NewItemButton cat) cx ty = editLink cx e0 ty ("a link for creating a new "++cat)
-renderExp exp@(Var i) cx ty@(Type cat) =
+renderExp e0@(Field cat field exp) cx ty =
+ editLink cx e0 ty ("the " & field & " of ")
+ & renderMaybeExp' exp (\e -> cx $ Field cat field $ Just e) (catType cat)
+renderExp e0@(AllItems cat) cx ty =
+ editLink cx e0 ty ("all the "++cat++"s in the system")
+renderExp e0@(NewItemButton cat) cx ty =
+ editLink cx e0 ty ("a link for creating a new "++cat)
+renderExp exp@(Var i) cx ty@(Type cat) =
editLink cx exp ty (cat & " '" & renderVar i & "'")
renderExp Today cx ty = editLink cx Today ty "today's date"
-renderExp e0@(SortByField cat field i exp) cx ty = renderMaybeExp' exp (\e -> cx $ SortByField cat field i $ Just e) (pluralType cat) & editLink cx e0 ty (", sorted by "++field++if i<0 then ", descending" else ", ascending")
-renderExp e0@(FilterByField cat field i exp exp0) cx ty = editLink cx e0 ty "those of " & renderMaybeExp' exp (\e -> cx $ FilterByField cat field i (Just e) exp0) (pluralType cat) & editLink cx e0 ty (" whose "++field++if i<0 then " comes before " else if i>0 then " comes after " else " is ") & renderExp exp0 (\e -> cx $ FilterByField cat field i exp e) string
-renderExp e0@(Forall cat i exp body) cx _ = editLink cx e0 string ("For each "&cat&" '"&renderVar i&"' of ") & renderMaybeExp' exp (\e -> cx $ Forall cat i (Just e) body) (pluralType cat)
- & editLink cx e0 string (":\n")
- & tag' "blockquote" (renderExp body (\e -> cx $ Forall cat i exp e) string)
+renderExp e0@(SortByField cat field i exp) cx ty =
+ renderMaybeExp' exp (\e -> cx $ SortByField cat field i $ Just e)
+ (pluralType cat)
+ & editLink cx e0 ty (", sorted by "++field++if i<0 then ", descending"
+ else ", ascending")
+renderExp e0@(FilterByField cat field i exp exp0) cx ty =
+ editLink cx e0 ty "those of "
+ & renderMaybeExp' exp (\e -> cx $ FilterByField cat field i (Just e) exp0)
+ (pluralType cat)
+ & editLink cx e0 ty (" whose "++field++if i<0 then " comes before "
+ else if i>0 then " comes after "
+ else " is ")
+ & renderExp exp0 (\e -> cx $ FilterByField cat field i exp e) string
+renderExp e0@(Forall cat i exp body) cx _ =
+ editLink cx e0 string ("For each "&cat&" '"&renderVar i&"' of ")
+ & renderMaybeExp' exp (\e -> cx$ Forall cat i (Just e) body) (pluralType cat)
+ & editLink cx e0 string (":\n")
+ & tag' "blockquote" (renderExp body (\e -> cx $ Forall cat i exp e) string)
renderExp (Str s) cx _ = tag "small" [] $ quoteP s
-renderExp exp@(Block exps) cx _ = para $ catMap (\(xs,x,xs') -> renderMaybeExp' x (\e -> cx (Block (xs ++ [Just e] ++ xs'))) string) (slices exps) & if ?link then para $ editLink cx exp string "[edit]" else toHTML ""
-renderExp exp@(Inline exps) cx _ = "\"" & catMap (\(xs,x,xs') -> renderMaybeExp' x (\e -> cx (Inline (xs ++ [Just e] ++ xs'))) string) (slices exps) & "\"" & if ?link then " " & editLink cx exp string "[edit]" else toHTML ""
+renderExp exp@(Block exps) cx _ = para $
+ flip catMap (slices exps) (\(xs,x,xs') ->
+ renderMaybeExp' x (\e -> cx (Block (xs ++ [Just e] ++ xs'))) string)
+ & if ?link then para $ editLink cx exp string "[edit]" else toHTML ""
+renderExp exp@(Inline exps) cx _ = ("\"" &) . (& "\"") $
+ flip catMap (slices exps) (\(xs,x,xs') ->
+ renderMaybeExp' x (\e -> cx (Inline (xs ++ [Just e] ++ xs'))) string)
+ & if ?link then " " & 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" [P "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]
@@ -116,15 +143,18 @@
isComplete (AllItems _) = True
isComplete (NewItemButton _) = True
isComplete (SortByField _ _ _ exp) = maybe False isComplete exp
-isComplete (FilterByField _ _ _ exp exp0) = maybe False isComplete exp && isComplete exp0
-isComplete (Forall _ _ exp body) = maybe False isComplete exp && isComplete body
+isComplete (FilterByField _ _ _ exp exp0) = maybe False isComplete exp
+ && isComplete exp0
+isComplete (Forall _ _ exp body) = maybe False isComplete exp
+ && isComplete body
isComplete (Var _) = True
isComplete (Block exps) = all (maybe False isComplete) exps
isComplete (Inline exps) = all (maybe False isComplete) exps
isComplete (Str _) = True
isComplete (Today) = True
-runExp :: (?root :: String, ?time :: Int64) => Env -> Exp -> StateT MyState [] Value
+runExp :: (?root :: String, ?time :: Int64)
+ => Env -> Exp -> StateT MyState [] Value
runExp env (Call fname args) = do
state <- get; let fn = readFun state fname
vals <- mapM (runExp env . fromJust) args
@@ -135,7 +165,8 @@
return $ itemFields (stateItems state Map.! read item) Map.! name
runExp env (AllItems cat) = do
state <- get
- msum [return $ show n | (n, Item _ cs) <- Map.toList (stateItems state), cat `Set.member` cs]
+ msum [return $ show n | (n, Item _ cs) <- Map.toList (stateItems state)
+ , cat `Set.member` cs]
runExp env (NewItemButton cat) = do
return $ html $ formP (?root++"newItem") $
hidden "returnTo" "" &
@@ -166,8 +197,9 @@
runExp _ Today = return $ renderTime ?time
renderTime :: Int64 -> String
-renderTime t0 = printf "%04u-%02u-%02u" (ctYear t) (fromEnum (ctMonth t)+1) (ctDay t)
- where t = toUTCTime (TOD (fromIntegral t0) 0)
+renderTime t0 =
+ printf "%04u-%02u-%02u" (ctYear t) (fromEnum (ctMonth t)+1) (ctDay t)
+ where t = toUTCTime (TOD (fromIntegral t0) 0)
runFun (Fun _ _ body) args =
runExp (Map.fromList [(i, args!!i) | i <- [0..length args-1]]) body
More information about the Fencommits
mailing list