[Fencommits] fenserve: use new potions code
Benja Fallenstein
benja.fallenstein at gmail.com
Fri Jun 15 16:42:49 EEST 2007
Fri Jun 15 16:25:57 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* use new potions code
diff -rN -u old-fenserve/fendata/Execution.hs new-fenserve/fendata/Execution.hs
--- old-fenserve/fendata/Execution.hs 2007-06-15 16:42:48.000000000 +0300
+++ new-fenserve/fendata/Execution.hs 1970-01-01 02:00:00.000000000 +0200
@@ -1,57 +0,0 @@
-{-# 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) => [Values] -> Exp -> Values
-runExp env (Var i) = env !! i
-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
- values = runExp env exp
- sortKeys = map (\v -> runExp ([v]:env) sortKeyExp) values
- sorted = map snd $ sort $ zip sortKeys values
- 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 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
- 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
- , catFor (runExp env exp) $ \item -> tag "tr" [] $
- catFor columns $ \(_,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-15 16:42:48.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-06-15 16:42:48.000000000 +0300
@@ -1,7 +1,6 @@
{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction #-}
import Rendering
-import Execution
import Types
import HTML
import Utils
@@ -95,6 +94,8 @@
( h2 "Table of all data in the database (if any)"
, catFor (Map.elems $ dbCategories ?db) $ \(Category cat name fs) ->
( h3 ("Category: ", name)
- , renderValues $ runExp [] $ TableView (AllItems cat) $
- map (\f -> (fieldName $ getField f, GetField f (Var 0))) fs))
+ , renderValues $ runExp [] $ Exp "tableView"
+ ( Exp "allItems" cat
+ , for fs $ \f -> ( fieldName $ getField f
+ , Exp "getField" ( f, Exp "var" (0::Int) )))))
]
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-06-15 16:42:48.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-06-15 16:42:48.000000000 +0300
@@ -7,18 +7,30 @@
import Utils
import Types
import Rendering
-import Execution
+import Data.Int
import Data.Generics
import Data.List
+import Data.Maybe (fromJust)
import System.Time
-data Potion = forall a r. (Data a, Read a, Show a, Ren r) =>
- Potion String (a -> (r, [Values] -> Values))
-
+data NumOp = Add | Subtract | Mul | Div
+ deriving (Read, Show, Typeable, Data, Eq, Ord)
+
+data CmpOp = Lt | Le | Eq | Ge | Gt
+ deriving (Read, Show, Typeable, Data, Eq, Ord)
+
+data Order = Asc | Desc
+ deriving (Read, Show, Typeable, Data, Eq, Ord)
+
mint ty (f, exec) = (I $ mintVar ty $ \var -> ren (f var), exec)
-
+
+runExp :: (?db :: DB, ?time :: Int64) => [Values] -> Exp -> Values
+runExp env (Exp name arg) = f potions where
+ f (Potion n g : xs) | n /= name = f xs | otherwise =
+ snd (g $ fromJust $ cast arg) env
+
potions =
[ Potion "var" $ \i ->
( ( varType i, " ", varName i )
@@ -28,14 +40,12 @@
( I $ renderValues values
, \env -> values )
-{- this should be handled by converting Funs to Potions:
-
+ -- XXX 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 )
diff -rN -u old-fenserve/fendata/Rendering.hs new-fenserve/fendata/Rendering.hs
--- old-fenserve/fendata/Rendering.hs 2007-06-15 16:42:48.000000000 +0300
+++ new-fenserve/fendata/Rendering.hs 2007-06-15 16:42:48.000000000 +0300
@@ -46,10 +46,6 @@
renderValues vs = commaList $ map renderValue $ vs
-data Env = Env { envVars :: [(String,Type)], envPath :: [Int], envWhole :: Exp }
-
-type RenderExp = ReaderT Env :$$: StateT Int :$$: Writer HTML
-
varType :: (?db :: DB) => Int -> RenderExp ()
varType i = ask >>= tell . toHTML . renderType . snd . (!! i) . envVars
@@ -72,8 +68,6 @@
expWithFocus = ask >>= \env -> return $ focusPath (envPath env) (envWhole env)
-class RenderOne a where renderOne :: (?db :: DB) => a -> RenderExp ()
-
data E = E Int Exp
instance RenderOne (RenderExp a) where renderOne m = m >> return ()
@@ -81,42 +75,10 @@
instance RenderOne Values where renderOne = renderOne . renderValues
instance ToHTML a => RenderOne a where renderOne x = tell (toHTML x)
instance RenderOne E where
- renderOne (E i e) =
- local (\env -> env { envPath = envPath env ++ [i] }) (renderExp' e)
-
-class Ren a where ren :: (?db :: DB) => a -> RenderExp ()
+ renderOne (E i e) = undefined
+ --local (\env -> env { envPath = envPath env ++ [i] }) (renderExp' e)
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) => Exp -> RenderExp ()
-renderExp' (Var i) = ren ( varType i, " ", varName i )
-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)
-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 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 )
-renderExp' (NumOp op e1 e2) = ren ( E 0 e1, " ", f op, " ", E 1 e2 ) where
- f Add = "+"; f Subtract = "-"; f Mul = "*"; f Div = "/"
-renderExp' (CmpOp op e1 e2) = ren ( E 0 e1, " ", f op, " ", E 1 e2 ) where
- f Lt = "<"; f Le = "<="; f Eq = "="; f Ge = ">="; f Gt = ">"
-renderExp' (Sum exp) = ren ( "the sum of ", E 0 exp )
-renderExp' (Product exp) = ren ( "the product of ", E 0 exp )
-renderExp' (Count exp) = ren ( "the number of ", E 0 exp )
-renderExp' (IfThenElse e1 e2 e3) = ren ( "if ", E 0 e1, " then ", E 1 e2
- , " else ", E 2 e3 )
-renderExp' Today = ren ( I "today's date" )
-renderExp' (Question ty) = ren ( "[which ", ty, "?]" )
-renderExp' (Focus exp) = ren ( I $ E 0 exp )
-
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs 2007-06-15 16:42:48.000000000 +0300
+++ new-fenserve/fendata/Types.hs 2007-06-15 16:42:48.000000000 +0300
@@ -8,8 +8,9 @@
import HAppS (StartState, startStateM)
-import Control.Monad.Reader (Reader)
+import Control.Monad.Reader (ReaderT)
import Control.Monad.State
+import Control.Monad.Writer (Writer)
import Data.Generics -- (Typeable, Typeable1, Data)
import Data.Map (Map)
@@ -26,6 +27,7 @@
type CategoryId = Id
type FieldId = Id
type ItemId = Id
+type FnId = Id
data BaseType = InlineType | BlockType | BooleanType | NumberType
| EmailType | WebLinkType | DateType | ItemType CategoryId
@@ -132,35 +134,29 @@
-- Potions
----------------------------------------------------------------------------
-type FnId = Id
+class RenderOne a where renderOne :: (?db :: DB) => a -> RenderExp ()
-data Order = Asc | Desc
- deriving (Read, Show, Typeable, Data, Eq, Ord)
+class Ren a where ren :: (?db :: DB) => a -> RenderExp ()
+
+data Env = Env { envVars :: [(String,Type)], envPath :: [Int], envWhole :: Exp }
+
+type RenderExp = ReaderT Env :$$: StateT Int :$$: Writer HTML
+
+
+data Potion = forall a r. (Data a, Read a, Show a, Ren r) =>
+ Potion String (a -> (r, [Values] -> Values))
+
+data Exp = forall a. (Data a, Read a, Show a) => Exp String a
+ | Question Type | Focus Exp
+ deriving Typeable
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
- deriving (Read, Show, Typeable, Data, Eq, Ord)
-
-data CmpOp = Lt | Le | Eq | Ge | Gt
- deriving (Read, Show, Typeable, Data, Eq, Ord)
-data Exp = Var Int
- | Call FnId [Exp]
- | Literal Values
- | GetField FieldId Exp
- | AllItems CategoryId
- | Sort BaseType Exp Exp Order
- | Filter BaseType Exp Exp
- | NumOp NumOp Exp Exp
- | CmpOp CmpOp Exp Exp
- | Sum Exp | Product Exp | Count Exp
- | IfThenElse Exp Exp Exp
- | Today
- | TableView Exp [(String, Exp)]
-
- | Question Type | Focus Exp
- deriving (Read, Show, Typeable, Data, Eq, Ord)
-
+instance Read Exp where
+instance Show Exp where
+instance Data Exp where
+instance Eq Exp where
+instance Ord Exp where
More information about the Fencommits
mailing list