[Fencommits] fenserve: start another refactoring of the potions code, bringing together the code defining, rendering and executing a primitive, and making it easier to make the set of primitives extensible
Benja Fallenstein
benja.fallenstein at gmail.com
Fri Jun 15 15:53:17 EEST 2007
Fri Jun 15 15:52:59 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* start another refactoring of the potions code, bringing together the code defining, rendering and executing a primitive, and making it easier to make the set of primitives extensible
diff -rN -u old-fenserve/fendata/Execution.hs new-fenserve/fendata/Execution.hs
--- old-fenserve/fendata/Execution.hs 2007-06-15 15:53:16.000000000 +0300
+++ new-fenserve/fendata/Execution.hs 2007-06-15 15:53:16.000000000 +0300
@@ -21,20 +21,18 @@
runExp :: (?db :: DB, ?time :: Int64) => [Values] -> Exp -> Values
runExp env (Var i) = env !! i
-runExp env (Call fun exps) = runExp (map (runExp env) exps) body where
- Fun _ _ _ body = dbFunctions ?db Map.! fun
+runExp env (Call fn exps) = runExp (map (runExp env) exps) (fnBody (getFn fn))
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
+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
+ f = case order of Asc -> id; Desc -> 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
+ f v = case runExp ([v]:env) filterExp of [BooleanValue b] -> b
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
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-06-15 15:53:16.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-06-15 15:53:16.000000000 +0300
@@ -7,6 +7,8 @@
import Utils
import TupleUtils (I(I), fromI)
+import Potions
+
import CSV
import HAppS
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/Potions.hs 2007-06-15 15:53:16.000000000 +0300
@@ -0,0 +1,106 @@
+{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction #-}
+
+module Potions where
+
+import TupleUtils
+import HTML
+import Utils
+import Types
+import Rendering
+import Execution
+
+import Data.Generics
+import Data.List
+
+import System.Time
+
+data Potion = forall a r. (Data a, Read a, Show a, Ren r) =>
+ Potion String (a -> (r, [Values] -> Values))
+
+mint ty (f, exec) = (I $ mintVar ty $ \var -> ren (f var), exec)
+
+potions =
+ [ Potion "var" $ \i ->
+ ( ( varType i, " ", varName i )
+ , \env -> env !! i )
+
+ , Potion "literal" $ \values ->
+ ( I $ renderValues values
+ , \env -> values )
+
+{- this should be handled by converting Funs to Potions:
+
+ , Potion "call" $ \(fn, args) ->
+ ( let f (TCons h x xs) (e:es) n = ren (h, E n e, f xs es (n+1))
+ f (TNil h) [] _ = ren (I h)
+ in I $ f (fnTemplate (getFn fn)) args 0
+ , \env -> runExp (map (runExp env) args) (fnBody (getFn fn)) )
+-}
+
+ , Potion "getField" $ \(field, exp) ->
+ ( ( "the ", fieldName $ getField field, " of ", E 0 exp )
+ , \env -> do ItemValue _ item <- runExp env exp; getValue item field )
+
+ , Potion "allItems" $ \cat ->
+ ( ( "all the ", plural $ catName $ getCategory cat, " in the database" )
+ , \_ -> map (ItemValue cat) $ map itemId $ getItems cat )
+
+ , Potion "sort" $ \(ty, e1, e2, order) -> mint (Single ty)
+ ( \var -> ( E 0 e1, " ", varName undefined, ", sorted by ", E 1 e2, ", "
+ , case order of Asc -> "asc"; Desc -> "desc" )
+ , \env -> let values = runExp env e1
+ sortKeys = map (\v -> runExp ([v]:env) e2) values
+ sorted = map snd $ sort $ zip sortKeys values
+ in case order of Asc -> sorted; Desc -> reverse sorted )
+
+ , Potion "filter" $ \(ty, e1, e2) -> mint (Single ty)
+ ( \var -> ( "those ", Multiple ty, " ", varName var, " of ", E 0 e1
+ , " such that ", E 1 e2 )
+ , \env -> let f v = case runExp ([v]:env) e2 of [BooleanValue b] -> b
+ in filter f $ runExp env e1 )
+
+ , Potion "numOp" $ \(op, e1, e2) ->
+ ( ( E 0 e1, " ", case op of Add->"+"; Subtract->"-"; Mul->"*"; Div->"/"
+ , " ", E 1 e2 )
+ , \env -> do NumberValue x <- runExp env e1
+ NumberValue y <- runExp env e2
+ return $ NumberValue $ case op of
+ Add -> x+y; Subtract -> x-y; Mul -> x*y; Div -> x/y )
+
+ , Potion "cmpOp" $ \(op, e1, e2) ->
+ ( ( E 0 e1, " ", case op of Lt->"<"; Le->"<="; Eq->"="; Ge->">="; Gt->">"
+ , " ", E 1 e2 )
+ , \env -> do x <- runExp env e1; y <- runExp env e2
+ return $ BooleanValue $ case op of
+ Lt->x<y; Le->x<=y; Eq->x==y; Ge->x>=y; Gt->x>y )
+
+ , Potion "sum" $ \exp ->
+ ( ( "the sum of ", E 0 exp )
+ , \env -> [NumberValue $ sum $ map numberValue $ runExp env exp] )
+
+ , Potion "product" $ \exp ->
+ ( ( "the product of ", E 0 exp )
+ , \env -> [NumberValue $ product $ map numberValue $ runExp env exp] )
+
+ , Potion "count" $ \exp ->
+ ( ( "the number of ", E 0 exp )
+ , \env -> [NumberValue $ fromIntegral $ length $ runExp env exp] )
+
+ , Potion "ifThenElse" $ \(e1, e2, e3) ->
+ ( ( "if ", E 0 e1, " then ", E 1 e2, " else ", E 2 e3 )
+ , \env -> runExp env $ case runExp env e1 of [BooleanValue True] -> e2
+ [BooleanValue False] -> e3 )
+
+ , Potion "today" $ \() ->
+ ( I "today's date"
+ , \env -> let t = toUTCTime (TOD (fromIntegral ?time) 0)
+ in [DateValue (ctYear t) (fromEnum (ctMonth t)+1) (ctDay t)] )
+
+ , Potion "tableView" $ \(exp, columns :: [(String,Exp)]) ->
+ ( I "XXX table view"
+ , \env -> 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/fendata/Rendering.hs new-fenserve/fendata/Rendering.hs
--- old-fenserve/fendata/Rendering.hs 2007-06-15 15:53:16.000000000 +0300
+++ new-fenserve/fendata/Rendering.hs 2007-06-15 15:53:16.000000000 +0300
@@ -93,18 +93,17 @@
renderExp' :: (?db :: DB) => Exp -> RenderExp ()
renderExp' (Var i) = ren ( varType i, " ", varName i )
-renderExp' (Call fun exps) = f template exps 0 where
+renderExp' (Call fn exps) = f (fnTemplate (getFn fn)) exps 0 where
f (TCons h x xs) (e:es) n = ren (h, E n e, f xs es (n+1))
f (TNil h) [] _ = ren (I h)
- Fun _ template _ body = dbFunctions ?db Map.! fun
renderExp' (Literal vals) = ren ( I vals )
renderExp' (GetField field exp) = ren
( "the ", fieldName $ getField field, " of ", E 0 exp )
renderExp' (AllItems cat) = ren
( "all the ", plural $ catName $ getCategory cat, " in the database" )
-renderExp' (Sort e1 e2 order) = ren
- ( E 0 e1, " sorted by ", E 1 e2, ", ", case order of
- Ascending -> "ascending"; Descending -> "descending" )
+renderExp' (Sort ty e1 e2 order) = mintVar (Single ty) $ \var -> ren
+ ( E 0 e1, " ", varName var, ", sorted by ", E 1 e2, ", ", case order of
+ Asc -> "asc"; Desc -> "desc" )
renderExp' (Filter ty e1 e2) = mintVar (Single ty) $ \var -> ren
( "those ", Multiple ty, " ", varName var, " of ", E 0 e1
, " such that ", E 1 e2 )
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs 2007-06-15 15:53:16.000000000 +0300
+++ new-fenserve/fendata/Types.hs 2007-06-15 15:53:16.000000000 +0300
@@ -61,7 +61,7 @@
data DB = DB { dbCategories :: Map CategoryId Category,
dbFields :: Map FieldId Field,
dbItems :: Map ItemId Item,
- dbFunctions :: Map FunId Fun }
+ dbFunctions :: Map FnId Function }
deriving (Read, Show, Typeable, Data, Eq, Ord)
instance StartState DB where
@@ -77,6 +77,7 @@
getField field = dbFields ?db Map.! field
getItem item = dbItems ?db Map.! item
getValue item field = let Item _ _ vs = getItem item in vs Map.! field
+getFn fn = dbFunctions ?db Map.! fn
getItems catId = filter (Set.member catId . itemCategories)
(Map.elems (dbItems ?db))
@@ -131,13 +132,13 @@
-- Potions
----------------------------------------------------------------------------
-type FunId = Id
+type FnId = Id
-data Order = Ascending | Descending
+data Order = Asc | Desc
deriving (Read, Show, Typeable, Data, Eq, Ord)
-data Fun = Fun { funId :: FunId, funTemplate :: Template Type,
- funResult :: Type, funBody :: Exp }
+data Function = Function { fnId :: FnId, fnTemplate :: Template Type,
+ fnResult :: Type, fnBody :: Exp }
deriving (Read, Show, Typeable, Data, Eq, Ord)
data NumOp = Add | Subtract | Mul | Div
@@ -147,11 +148,11 @@
deriving (Read, Show, Typeable, Data, Eq, Ord)
data Exp = Var Int
- | Call FunId [Exp]
+ | Call FnId [Exp]
| Literal Values
| GetField FieldId Exp
| AllItems CategoryId
- | Sort Exp Exp Order
+ | Sort BaseType Exp Exp Order
| Filter BaseType Exp Exp
| NumOp NumOp Exp Exp
| CmpOp CmpOp Exp Exp
More information about the Fencommits
mailing list