[Fencommits] fenserve: unfinished code for rendering potion expressions

[Benja Fallenstein]

Tue Jun  5 17:45:49 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * unfinished code for rendering potion expressions
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs	2007-06-05 17:46:07.000000000 +0300
+++ new-fenserve/fendata/Potions.hs	2007-06-05 17:46:07.000000000 +0300
@@ -11,10 +11,12 @@
 
 import Data.Int (Int64)
 import Data.List (sort)
-import Data.Generics (Typeable, everything, mkQ)
+import Data.Generics (Typeable, everything, mkQ, extQ, gmapQr)
 import Data.Map (Map)
 import qualified Data.Map as Map
 
+import Text.Printf (printf)
+
 import System.Time
 
 
@@ -28,9 +30,12 @@
 template = mkTemplate . toHList
 
 
-renderTemplate :: Typeable a => (a -> HTML) -> Template a -> HTML
-renderTemplate f (TCons h x tl) = h & f x & renderTemplate f tl
-renderTemplate _ (TNil h) = h
+--renderTemplate :: Typeable a => (a -> HTML) -> Template a -> HTML
+--renderTemplate f (TCons h x tl) = h & f x & renderTemplate f tl
+--renderTemplate _ (TNil h) = h
+
+templateHTML (TCons h _ tl) = h : templateHTML tl
+templateHTML (TNil h) = [h]
 
 templateValues (TCons _ x tl) = x : templateValues tl
 templateValues (TNil _) = []
@@ -44,13 +49,85 @@
 
 
 ----------------------------------------------------------------------------
+-- Rendering
+----------------------------------------------------------------------------
+
+{-
+renderExp (CmpOp op e1 e2) = do
+    let s = case op of Lt = "less than" ...
+    renderExp e1; editLink (" is ", s, " "); renderExp e2
+-}
+
+zipHTML :: [HTML] -> [HTML] -> HTML
+zipHTML (x:xs) (y:ys) = x & y & zipHTML xs ys
+zipHTML xs     ys     = cat xs & cat ys
+
+renderType (Single InlineType) = "text"
+renderType (Multiple InlineType) = "pieces of text"
+renderType (Single BlockType) = "block of text"
+renderType (Multiple BlockType) = "blocks of text"
+renderType t = case t of Single t' -> f t'; Multiple t' -> plural (f t')
+  where
+    f BooleanType = "condition"
+    f NumberType = "number"
+    f EmailType = "email address"
+    f WebLinkType = "web link"
+    f DateType = "date"
+    f (ItemType cat) = catName $ getCategory cat
+
+renderValue (InlineValue s) = toHTML s
+renderValue (BlockValue s) = toHTML s -- XXX
+renderValue (BooleanValue False) = toHTML "No"
+renderValue (BooleanValue True) = toHTML "Yes"
+renderValue (NumberValue x) = toHTML (show x)
+renderValue (EmailValue s) = link ("mailto:"++s) s
+renderValue (WebLinkValue s) = link s s
+renderValue (DateValue y m d) = toHTML (printf "%04u-%02u-%02u" y m d :: String)
+renderValue (ItemValue _ i) = "Item " & show i -- XXX
+
+renderValues vs = commaList $ map renderValue $ vs
+    
+    
+renderExp exp = zipHTML (let ?env = undefined in 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
+    template (Call fun _) = map html $ templateHTML tmp where
+        Fun tmp _ _ = ?funs Map.! fun
+    template (Literal vals) = [html $ renderValues vals]
+    template (GetField _ field _) = 
+        ["the " ++ (fieldName $ getField field) ++ " of ", ""]
+    template (AllItems cat) = 
+        ["all the " ++ (plural $ catName $ getCategory cat) 
+         ++ " in the database"]
+    template (Sort _ _ order) = ["", " sorted by ", ", " ++ f order]
+        where f Ascending = "ascending"; f Descending = "descending"
+    template (Filter _ _) = ["those of ", " such that ", ""]
+    template (NumOp op _ _) = ["", " " ++ f op ++ " " , ""]
+        where f Add = "+"; f Subtract = "-"; f Mul = "*"; f Div = "/"
+    template (CmpOp op _ _) = ["", " " ++ f op ++ " " , ""]
+        where f Lt = "<"; f Le = "<="; f Eq = "="; f Ge = ">="; f Gt = ">"
+    template (Sum _) = ["the sum of ", ""]
+    template (Product _) = ["the product of ", ""]
+    template (Count _) = ["the count of ", ""]
+    template (IfThenElse _ _ _) = ["if ", " then ", " else ", ""]
+    template Today = ["today's date"]
+    template (Question ty) = ["[which " ++ renderType ty ++ "?]"]
+    template (Focus _) = ["", ""]
+    
+
+
+----------------------------------------------------------------------------
 -- Execution
 ----------------------------------------------------------------------------
 
-runExp :: (?db :: DB, ?time :: Int64) => [Values] -> Exp -> Values
+runExp :: (?db :: DB, ?time :: Int64, ?funs :: Map FunId Fun) => 
+          [Values] -> Exp -> Values
 runExp env (Var i) = env !! i
-runExp env (Call funId exps) = runExp (map (runExp env) exps) fun where
-    Fun _ _ fun = undefined
+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
     ItemValue _ item <- runExp env exp;  getValue item field
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs	2007-06-05 17:46:07.000000000 +0300
+++ new-fenserve/fendata/Types.hs	2007-06-05 17:46:07.000000000 +0300
@@ -58,9 +58,10 @@
                dbItems :: Map ItemId Item, dbNextId :: Int }
     deriving (Read, Show, Typeable, Data, Eq, Ord)
     
-getValue item field = let Item _ _ vs = getItem item in vs Map.! field
-getItem item = dbItems ?db Map.! item
 getCategory cat = dbCategories ?db Map.! cat
+getField field = dbFields ?db Map.! field
+getItem item = dbItems ?db Map.! item
+getValue item field = let Item _ _ vs = getItem item in vs Map.! field
 
 getItems catId = filter (Set.member catId . itemCategories) 
                         (Map.elems (dbItems ?db))