[Fencommits] fenserve: split rendering and execution into separate modules, cleanup
Benja Fallenstein
benja.fallenstein at gmail.com
Wed Jun 13 23:14:49 EEST 2007
Wed Jun 13 23:14:32 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* split rendering and execution into separate modules, cleanup
diff -rN -u old-fenserve/fendata/Execution.hs new-fenserve/fendata/Execution.hs
--- old-fenserve/fendata/Execution.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/Execution.hs 2007-06-13 23:14:49.000000000 +0300
@@ -0,0 +1,62 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+module Execution where
+
+import HTML
+import Types
+import Utils
+import Rendering (renderValues)
+import TupleUtils
+
+import Control.Monad
+
+import Data.List (sort)
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Data.Int (Int64)
+
+import System.Time
+
+
+runExp :: (?db :: DB, ?time :: Int64, ?funs :: Map FunId Fun) =>
+ [Values] -> (I Exp) -> Values
+runExp env = runExp' env . fromI
+
+runExp' env (Var i) = env !! i
+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
+runExp' env (AllItems cat) = map (ItemValue cat) $ map itemId $ getItems cat
+runExp' env (Sort exp sortKeyExp order) = f sorted where
+ values = runExp env exp
+ sortKeys = map (\v -> runExp ([v]:env) sortKeyExp) values
+ sorted = map snd $ sort $ zip sortKeys values
+ f = case order of Ascending -> id; Descending -> reverse
+runExp' env (Filter _ exp filterExp) = filter f $ runExp env exp where
+ f v = case runExp ([v]:env) filterExp of
+ [BooleanValue True] -> True; [BooleanValue False] -> False
+runExp' env (NumOp op e1 e2) = do
+ let f Add = (+); f Subtract = (-); f Mul = (*); f Div = (/)
+ NumberValue a <- runExp env e1; NumberValue b <- runExp env e2
+ return $ NumberValue $ f op a b
+runExp' env (CmpOp op e1 e2) = do
+ let f Lt = (<); f Le = (<=); f Eq = (==); f Ge = (>=); f Gt = (>)
+ a <- runExp env e1; b <- runExp env e2
+ return $ BooleanValue $ f op a b
+runExp' env (Sum exp) = [NumberValue $ sum $ map numberValue $ runExp env exp]
+runExp' env (Product exp) =
+ [NumberValue $ product $ map numberValue $ runExp env exp]
+runExp' env (Count exp) = [NumberValue $ fromIntegral $ length $ runExp env exp]
+runExp' env (IfThenElse e1 e2 e3) = runExp env $ case runExp env e1 of
+ [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 . fromI
+ , catFor (runExp env exp) $ \item -> tag "tr" [] $
+ catFor columns $ \(I (_,exp')) ->
+ tag "td" [] $ renderValues $ runExp' ([item]:env) exp' )
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-06-13 23:14:49.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-06-13 23:14:49.000000000 +0300
@@ -1,6 +1,7 @@
{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction #-}
-import Potions
+import Rendering
+import Execution
import Types
import HTML
import Utils
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-06-13 23:14:49.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 1970-01-01 02:00:00.000000000 +0200
@@ -1,200 +0,0 @@
-{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances #-}
-
-module Potions where
-
-import HTML
-import Types
-import TupleUtils
-import Utils
-
-import Control.Monad
-import Control.Monad.Reader (ReaderT, ask, local)
-import Control.Monad.State (StateT, get, put)
-import Control.Monad.Writer (Writer, tell)
-
-import Data.Int (Int64)
-import Data.List (sort)
-import Data.Generics (Typeable, Typeable1, everything, mkQ, extQ, gmapQr)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Typeable
-
-import Text.Printf (printf)
-
-import System.Time
-
-
-{-
-class Typeable b => ToTemplate a b where template :: a -> Template b
-instance (ToHTML h, Typeable a) => ToTemplate (Identity h) a where
- template (Identity h) = TNil (toHTML h)
-instance (ToHTML h, Typeable a, Tuple h t' t, Tuple a xs t', ToTemplate xs a)
- => ToTemplate t a where
- template t | (h,x,xs) <- tsplit2 t = TCons (toHTML h) x (template xs)
-
-
---renderTemplate :: Typeable a => (a -> HTML) -> Template a -> HTML
---renderTemplate f (Tuple 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 _) = []
--}
-
-
-{-
-varCount :: Exp -> Int
-varCount = everything (+) (0 `mkQ` \e -> case e of Forall _ _ _ -> 1
- otherwise -> 0)
--}
-
-
-----------------------------------------------------------------------------
--- 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) = s
-renderValue (BlockValue s) = s
-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
-
-
-newtype Cx a = Cx (a, a -> Exp)
-type CxExp = Exp' Cx
-
-instance Typeable1 Cx where
- typeOf1 (_ :: Cx a) = mkTyConApp (mkTyCon "Cx") []
-
-
-type RenderExp = ReaderT [(String,Type)] (StateT Int (Writer HTML))
-
-varType :: (?db :: DB) => Int -> RenderExp ()
-varType i = ask >>= return . toHTML . renderType . snd . (!! i) >>= tell
-
-varName :: (?db :: DB) => Int -> RenderExp ()
-varName i = fmap (!! i) ask >>= \(name,_) -> ren ("'", ital name, "'")
-
-mintVar :: Type -> (Int -> RenderExp a) -> RenderExp a
-mintVar t f = do var <- get; put (var + 1); local (("v"++show var,t):) (f var)
-
-
-class RenderOne a where renderOne :: (?db :: DB) => a -> RenderExp ()
-
-instance RenderOne (RenderExp a) where renderOne m = m >> return ()
-instance RenderOne Type where renderOne = renderOne . renderType
-instance RenderOne Values where renderOne = renderOne . renderValues
-instance RenderOne (Cx CxExp) where renderOne (Cx (e,cx)) = renderExp' e
-instance ToHTML a => RenderOne a where renderOne x = tell (toHTML x)
-
-class Ren a where ren :: (?db :: DB) => a -> RenderExp ()
-
-instance Ren () where ren () = return ()
-instance (RenderOne x, Ren xs, Tuple x xs t) => Ren t where
- ren t | (x,xs) <- tsplit1 t = renderOne x >> ren xs
-
-
-renderExp' :: (?db :: DB) => CxExp -> RenderExp ()
-renderExp' (Var i) = ren ( varType i, " ", varName i )
---renderExp' (Call fun exps) =
-renderExp' (Literal vals) = ren ( I vals )
-renderExp' (GetField field exp) = ren
- ( "the ", fieldName $ getField field, " of ", exp )
-renderExp' (AllItems cat) = ren
- ( "all the ", plural $ catName $ getCategory cat, " in the database" )
-renderExp' (Sort e1 e2 o) = ren
- ( e1, " sorted by ", e2, ", ", case o of Ascending -> "ascending"
- Descending -> "descending" )
-renderExp' (Filter ty e1 e2) = mintVar (Single ty) $ \var -> ren
- ( "those ", Multiple ty, " ", varName var, " of ", e1, " such that ", e2 )
-renderExp' (NumOp op e1 e2) = ren ( e1, " ", f op, " ", e2 ) where
- f Add = "+"; f Subtract = "-"; f Mul = "*"; f Div = "/"
-renderExp' (CmpOp op e1 e2) = ren ( e1, " ", f op, " ", e2 ) where
- f Lt = "<"; f Le = "<="; f Eq = "="; f Ge = ">="; f Gt = ">"
-renderExp' (Sum exp) = ren ( "the sum of ", exp )
-renderExp' (Product exp) = ren ( "the product of ", exp )
-renderExp' (Count exp) = ren ( "the number of ", exp )
-renderExp' (IfThenElse e1 e2 e3) = ren ("if ", e1, " then ", e2, " else ", e3)
-renderExp' Today = ren ( I "today's date" )
-renderExp' (Question ty) = ren ( "[which ", ty, "?]" )
-renderExp' (Focus exp) = ren ( I exp )
-
-
-
-----------------------------------------------------------------------------
--- Execution
-----------------------------------------------------------------------------
-
-runExp :: (?db :: DB, ?time :: Int64, ?funs :: Map FunId Fun) =>
- [Values] -> (I Exp) -> Values
-runExp env = runExp' env . fromI
-
-runExp' env (Var i) = env !! i
-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
-runExp' env (AllItems cat) = map (ItemValue cat) $ map itemId $ getItems cat
-runExp' env (Sort exp sortKeyExp order) = f sorted where
- values = runExp env exp
- sortKeys = map (\v -> runExp ([v]:env) sortKeyExp) values
- sorted = map snd $ sort $ zip sortKeys values
- f = case order of Ascending -> id; Descending -> reverse
-runExp' env (Filter _ exp filterExp) = filter f $ runExp env exp where
- f v = case runExp ([v]:env) filterExp of
- [BooleanValue True] -> True; [BooleanValue False] -> False
-runExp' env (NumOp op e1 e2) = do
- let f Add = (+); f Subtract = (-); f Mul = (*); f Div = (/)
- NumberValue a <- runExp env e1; NumberValue b <- runExp env e2
- return $ NumberValue $ f op a b
-runExp' env (CmpOp op e1 e2) = do
- let f Lt = (<); f Le = (<=); f Eq = (==); f Ge = (>=); f Gt = (>)
- a <- runExp env e1; b <- runExp env e2
- return $ BooleanValue $ f op a b
-runExp' env (Sum exp) = [NumberValue $ sum $ map numberValue $ runExp env exp]
-runExp' env (Product exp) =
- [NumberValue $ product $ map numberValue $ runExp env exp]
-runExp' env (Count exp) = [NumberValue $ fromIntegral $ length $ runExp env exp]
-runExp' env (IfThenElse e1 e2 e3) = runExp env $ case runExp env e1 of
- [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 . fromI
- , catFor (runExp env exp) $ \item -> tag "tr" [] $
- catFor columns $ \(I (_,exp')) ->
- tag "td" [] $ renderValues $ runExp' ([item]:env) exp' )
diff -rN -u old-fenserve/fendata/Rendering.hs new-fenserve/fendata/Rendering.hs
--- old-fenserve/fendata/Rendering.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/Rendering.hs 2007-06-13 23:14:49.000000000 +0300
@@ -0,0 +1,107 @@
+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances #-}
+
+module Rendering where
+
+import HTML
+import Types
+import TupleUtils
+import Utils
+
+import Control.Monad
+import Control.Monad.Reader (ReaderT, ask, local)
+import Control.Monad.State (StateT, get, put)
+import Control.Monad.Writer (Writer, tell)
+
+import Data.Generics (Typeable, Typeable1, everything, mkQ, extQ, gmapQr)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Typeable
+
+import Text.Printf
+
+
+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) = s
+renderValue (BlockValue s) = s
+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
+
+
+newtype Cx a = Cx (a, a -> Exp)
+type CxExp = Exp' Cx
+
+instance Typeable1 Cx where
+ typeOf1 (_ :: Cx a) = mkTyConApp (mkTyCon "Cx") []
+
+
+type RenderExp = ReaderT [(String,Type)] (StateT Int (Writer HTML))
+
+varType :: (?db :: DB) => Int -> RenderExp ()
+varType i = ask >>= return . toHTML . renderType . snd . (!! i) >>= tell
+
+varName :: (?db :: DB) => Int -> RenderExp ()
+varName i = fmap (!! i) ask >>= \(name,_) -> ren ("'", ital name, "'")
+
+mintVar :: Type -> (Int -> RenderExp a) -> RenderExp a
+mintVar t f = do var <- get; put (var + 1); local (("v"++show var,t):) (f var)
+
+
+class RenderOne a where renderOne :: (?db :: DB) => a -> RenderExp ()
+
+instance RenderOne (RenderExp a) where renderOne m = m >> return ()
+instance RenderOne Type where renderOne = renderOne . renderType
+instance RenderOne Values where renderOne = renderOne . renderValues
+instance RenderOne (Cx CxExp) where renderOne (Cx (e,cx)) = renderExp' e
+instance ToHTML a => RenderOne a where renderOne x = tell (toHTML x)
+
+class Ren a where ren :: (?db :: DB) => a -> RenderExp ()
+
+instance Ren () where ren () = return ()
+instance (RenderOne x, Ren xs, Tuple x xs t) => Ren t where
+ ren t | (x,xs) <- tsplit1 t = renderOne x >> ren xs
+
+
+renderExp' :: (?db :: DB) => CxExp -> RenderExp ()
+renderExp' (Var i) = ren ( varType i, " ", varName i )
+--renderExp' (Call fun exps) =
+renderExp' (Literal vals) = ren ( I vals )
+renderExp' (GetField field exp) = ren
+ ( "the ", fieldName $ getField field, " of ", exp )
+renderExp' (AllItems cat) = ren
+ ( "all the ", plural $ catName $ getCategory cat, " in the database" )
+renderExp' (Sort e1 e2 o) = ren
+ ( e1, " sorted by ", e2, ", ", case o of Ascending -> "ascending"
+ Descending -> "descending" )
+renderExp' (Filter ty e1 e2) = mintVar (Single ty) $ \var -> ren
+ ( "those ", Multiple ty, " ", varName var, " of ", e1, " such that ", e2 )
+renderExp' (NumOp op e1 e2) = ren ( e1, " ", f op, " ", e2 ) where
+ f Add = "+"; f Subtract = "-"; f Mul = "*"; f Div = "/"
+renderExp' (CmpOp op e1 e2) = ren ( e1, " ", f op, " ", e2 ) where
+ f Lt = "<"; f Le = "<="; f Eq = "="; f Ge = ">="; f Gt = ">"
+renderExp' (Sum exp) = ren ( "the sum of ", exp )
+renderExp' (Product exp) = ren ( "the product of ", exp )
+renderExp' (Count exp) = ren ( "the number of ", exp )
+renderExp' (IfThenElse e1 e2 e3) = ren ("if ", e1, " then ", e2, " else ", e3)
+renderExp' Today = ren ( I "today's date" )
+renderExp' (Question ty) = ren ( "[which ", ty, "?]" )
+renderExp' (Focus exp) = ren ( I exp )
+
More information about the Fencommits
mailing list