[Fencommits] fenserve: refactor: run new_... in the state monad

[Benja Fallenstein]

Tue Jun  5 20:48:47 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * refactor: run new_... in the state monad
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs	2007-06-05 20:48:59.000000000 +0300
+++ new-fenserve/fendata/Potions.hs	2007-06-05 20:48:59.000000000 +0300
@@ -88,12 +88,12 @@
 renderValues vs = commaList $ map renderValue $ vs
     
     
-renderExp exp = zipHTML (let ?env = undefined in map toHTML $ template exp) $ gmapQr (++) [] f exp where
+renderExp exp = zipHTML (map toHTML $ template exp) $ gmapQr (++) [] f exp where
     f :: (Typeable a) => a -> [HTML]
     f = mkQ [] (\e -> [renderExp e]) `extQ` (map renderExp)
     
     template (Var i) = [renderType ty ++ " '" ++ name ++ "'"] where
-        (name :: String,ty) = ?env !! i
+        (name,ty) = ?env !! i
     template (Call fun _) = map html $ templateHTML tmp where
         Fun tmp _ _ = ?funs Map.! fun
     template (Literal vals) = [html $ renderValues vals]
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs	2007-06-05 20:48:59.000000000 +0300
+++ new-fenserve/fendata/Types.hs	2007-06-05 20:48:59.000000000 +0300
@@ -6,6 +6,7 @@
 import Utils
 
 import Control.Monad.Reader (Reader)
+import Control.Monad.State
 
 import Data.Generics (Typeable, Data)
 import Data.Map (Map)
@@ -18,9 +19,10 @@
 -- Data
 ----------------------------------------------------------------------------
 
-type CategoryId = Int
-type FieldId = Int
-type ItemId = Int
+type Id = Int
+type CategoryId = Id
+type FieldId = Id
+type ItemId = Id
 
 data BaseType = InlineType | BlockType | BooleanType | NumberType
               | EmailType | WebLinkType | DateType | ItemType CategoryId
@@ -55,7 +57,7 @@
 
 data DB = DB { dbCategories :: Map CategoryId Category,
                dbFields :: Map FieldId Field,
-               dbItems :: Map ItemId Item, dbNextId :: Int }
+               dbItems :: Map ItemId Item }
     deriving (Read, Show, Typeable, Data, Eq, Ord)
     
 getCategory cat = dbCategories ?db Map.! cat
@@ -76,25 +78,27 @@
 u_itemCategories f (Item a b c) = Item a (f b) c
 u_itemValues     f (Item a b c) = Item a b (f c)
 
-u_dbCategories f (DB a b c d) = DB (f a) b c d
-u_dbFields     f (DB a b c d) = DB a (f b) c d
-u_dbItems      f (DB a b c d) = DB a b (f c) d
+u_dbCategories f (DB a b c) = DB (f a) b c
+u_dbFields     f (DB a b c) = DB a (f b) c
+u_dbItems      f (DB a b c) = DB a b (f c)
 
 u_cat   x f = u_dbCategories $ Map.adjust f x
 u_field x f = u_dbFields $ Map.adjust f x
 u_item  x f = u_dbItems $ Map.adjust f x
 
-new_cat name (DB a b c d) =
-    (d, DB (Map.insert d (Category d name [d+1]) a)
-           (Map.insert (d+1) (Field (d+1) "Name" d (Single InlineType)) b) 
-           c (d+2))
-
-new_field name cat ty (DB a b c d) =
-    (d, u_cat cat (u_catFields (++[d]))
-      $ DB a (Map.insert d (Field d name cat ty) b) c (d+1))
+new :: a -> State (Map Id a) Id
+new x = State $ \m -> let i = if Map.null m then 0 else fst (Map.findMax m) + 1
+                       in (i, Map.insert i x m)
+                       
+new_cat name = mfix $ \cat -> mdo
+    field <- new_field "Name" cat $ Single InlineType
+    inside dbCategories u_dbCategories $ new $ Category cat name [field]
+                   
+new_field name cat ty = mfix $ \field ->
+    inside dbFields u_dbFields $ new $ Field field name cat ty
       
-new_item cats (DB a b c d) = 
-    (d, DB a b (Map.insert d (Item d cats Map.empty) c) (d+1))
+new_item cats = mfix $ \item -> 
+    inside dbItems u_dbItems $ new $ Item item cats Map.empty
 
 
 
diff -rN -u old-fenserve/fendata/Utils.hs new-fenserve/fendata/Utils.hs
--- old-fenserve/fendata/Utils.hs	2007-06-05 20:48:59.000000000 +0300
+++ new-fenserve/fendata/Utils.hs	2007-06-05 20:48:59.000000000 +0300
@@ -5,6 +5,8 @@
 import HAppS
 import HTML
 
+import Control.Monad.State
+
 import Data.Char (toUpper, toLower)
 import Data.List (intersperse)
 import Data.Maybe (fromMaybe)
@@ -32,6 +34,20 @@
 insertIfNew k v = Map.alter (Just . fromMaybe v) k
 
 
+type Getter inner outer = outer -> inner
+type Changer inner outer = Endo inner -> Endo outer
+
+sets :: Changer inner outer -> inner -> Endo outer
+sets chg x = chg (const x)
+
+puts :: MonadState o m => Changer i o -> i -> m ()
+puts chg x = modify (sets chg x)
+
+inside :: Getter i o -> Changer i o -> State i a -> State o a
+inside g f m = State $ \o -> let (r,i') = runState m (g o) in (r, sets f i' o)
+
+
+
 escape' = concatMap escapeMore . escape where
   escapeMore '[' = "%5b"; escapeMore ']' = "%5d"; 
       escapeMore '&' = "%26"; escapeMore c = [c]
@@ -66,6 +82,7 @@
 uncapitalize "" = ""
 
 plural s | last s == 'y' = init s ++ "ies"
+         | last s == 's' = init s ++ "es"
          | otherwise     = s ++ "s"
     
 mdot = style "margin-left: 0.5em; margin-right: 0.5em; font-weight: bold" $