[Fencommits] fenserve: make the table view a potion

[Benja Fallenstein]

Sat Jun  9 07:07:01 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * make the table view a potion
diff -rN -u old-fenserve-1/fendata/Main.hs new-fenserve-1/fendata/Main.hs
--- old-fenserve-1/fendata/Main.hs	2007-06-09 07:07:46.000000000 +0300
+++ new-fenserve-1/fendata/Main.hs	2007-06-09 07:07:46.000000000 +0300
@@ -18,6 +18,7 @@
                , h (Prefix ()) () $ \(path::[String]) req -> do
                    getTime -> time; get -> state :: DB
                    let ?time = time; ?state = state; ?db = state; ?req = req
+                       ?funs = Map.empty
                        ?root = concatMap (const "../") $ drop 1 path
                    runServerParts [app] req
                ]
@@ -83,15 +84,12 @@
         forM_ rows $ \r -> do
             item <- new_item $ Set.singleton cat
             forM_ (zip fields r) $ \(field, value) ->
-                modify $ u_value item field [InlineValue value]
+                modify $ u_value item field [InlineValue $ toHTML value]
                 
   , page ["table"] "Table"
       ( h2 "Table of all data in the database (if any)"
       , catFor (Map.elems $ dbCategories ?db) $ \(Category cat name fs) ->
           ( h3 ("Category ", name)
-          , tag "table" [P "border" "1"]
-              ( tag "tr" [] $ catFor fs $ tag "th" [] . fieldName . getField
-              , catFor (getItems cat) $ \(Item _ _ vs) ->
-                  ( tag "tr" [] $ catFor fs $ \f ->
-                      tag "td" [] $ renderValues $ Map.findWithDefault [] f vs))))
+          , renderValues $ runExp [] $ TableView (AllItems cat) $
+                map (\f -> (fieldName $ getField f, GetField f (Var 0))) fs))
   ]
diff -rN -u old-fenserve-1/fendata/Potions.hs new-fenserve-1/fendata/Potions.hs
--- old-fenserve-1/fendata/Potions.hs	2007-06-09 07:07:46.000000000 +0300
+++ new-fenserve-1/fendata/Potions.hs	2007-06-09 07:07:46.000000000 +0300
@@ -75,8 +75,8 @@
     f DateType = "date"
     f (ItemType cat) = catName $ getCategory cat
 
-renderValue (InlineValue s) = toHTML s
-renderValue (BlockValue s) = toHTML s -- XXX
+renderValue (InlineValue s) = s
+renderValue (BlockValue s) = s
 renderValue (BooleanValue False) = toHTML "No"
 renderValue (BooleanValue True) = toHTML "Yes"
 renderValue (NumberValue x) = toHTML (show x)
@@ -97,7 +97,7 @@
     template (Call fun _) = map html $ templateHTML tmp where
         Fun tmp _ _ = ?funs Map.! fun
     template (Literal vals) = [html $ renderValues vals]
-    template (GetField _ field _) = 
+    template (GetField field _) = 
         ["the " ++ (fieldName $ getField field) ++ " of ", ""]
     template (AllItems cat) = 
         ["all the " ++ (plural $ catName $ getCategory cat) 
@@ -129,7 +129,7 @@
 runExp env (Call fun exps) = runExp (map (runExp env) exps) body where
     Fun _ _ body = ?funs Map.! fun
 runExp env (Literal val) = val
-runExp env (GetField _ field exp) = do
+runExp env (GetField field exp) = do
     ItemValue _ item <- runExp env exp;  getValue item field
 runExp env (AllItems cat) = map (ItemValue cat) $ map itemId $ getItems cat    
 runExp env (Sort exp sortKeyExp order) = f sorted where
@@ -156,4 +156,9 @@
     [BooleanValue True] -> e2; [BooleanValue False] -> e3
 runExp env Today = [DateValue (ctYear t) (fromEnum (ctMonth t)+1) (ctDay t)]
   where t = toUTCTime (TOD (fromIntegral ?time) 0)
-
+runExp env (TableView exp columns) = return $ BlockValue $
+    tag "table" [P "border" "1"]
+      ( tag "tr" [] $ catFor columns $ tag "th" [] . fst
+      , catFor (runExp env exp) $ \item -> tag "tr" [] $
+            catFor columns $ \(_,exp') ->
+                tag "td" [] $ renderValues $ runExp ([item]:env) exp' )
diff -rN -u old-fenserve-1/fendata/Types.hs new-fenserve-1/fendata/Types.hs
--- old-fenserve-1/fendata/Types.hs	2007-06-09 07:07:46.000000000 +0300
+++ new-fenserve-1/fendata/Types.hs	2007-06-09 07:07:46.000000000 +0300
@@ -33,8 +33,8 @@
 data Type = Single BaseType | Multiple BaseType
     deriving (Read, Show, Typeable, Data, Eq, Ord)
 
-data Value = InlineValue String
-           | BlockValue String
+data Value = InlineValue HTML
+           | BlockValue HTML
            | BooleanValue Bool
            | NumberValue { numberValue :: Float }
            | EmailValue String
@@ -104,8 +104,7 @@
                        in (i, Map.insert i x m)
                        
 new_category name = mfix $ \cat -> do
-    field <- new_field "Name" cat $ Single InlineType
-    inside dbCategories u_dbCategories $ new $ Category cat name [field]
+    inside dbCategories u_dbCategories $ new $ Category cat name []
                    
 new_field name cat ty = mfix $ \field -> do
     modify $ u_cat cat $ u_catFields $ (++[field])
@@ -147,7 +146,7 @@
 data Exp = Var Int
          | Call FunId [Exp]
          | Literal Values
-         | GetField CategoryId FieldId Exp
+         | GetField FieldId Exp
          | AllItems CategoryId
          | Sort Exp Exp Order
          | Filter Exp Exp
@@ -156,6 +155,8 @@
          | IfThenElse Exp Exp Exp
          | Today
          
+         | TableView Exp [(String, Exp)]
+         
          | Question Type | Focus Exp
     deriving (Read, Show, Typeable, Data, Eq, Ord)