[Fencommits] fenserve: implement keeping track of the focused part of the expression in renderExp; simplify Exp type
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Jun 14 01:11:05 EEST 2007
Thu Jun 14 01:10:51 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* implement keeping track of the focused part of the expression in renderExp; simplify Exp type
diff -rN -u old-fenserve/fendata/Execution.hs new-fenserve/fendata/Execution.hs
--- old-fenserve/fendata/Execution.hs 2007-06-14 01:11:05.000000000 +0300
+++ new-fenserve/fendata/Execution.hs 2007-06-14 01:11:05.000000000 +0300
@@ -20,43 +20,41 @@
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
+ [Values] -> Exp -> Values
+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
+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 (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
+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
+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
+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) =
+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
+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)]
+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 $
+runExp env (TableView exp columns) = return $ BlockValue $
tag "table" [P "border" "1"]
- ( tag "tr" [] $ catFor columns $ tag "th" [] . fst . fromI
+ ( tag "tr" [] $ catFor columns $ tag "th" [] . fst
, catFor (runExp env exp) $ \item -> tag "tr" [] $
- catFor columns $ \(I (_,exp')) ->
- tag "td" [] $ renderValues $ runExp' ([item]:env) exp' )
+ 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-14 01:11:05.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-06-14 01:11:05.000000000 +0300
@@ -93,6 +93,6 @@
( h2 "Table of all data in the database (if any)"
, catFor (Map.elems $ dbCategories ?db) $ \(Category cat name fs) ->
( h3 ("Category: ", name)
- , renderValues $ runExp [] $ I $ TableView (I $ AllItems cat) $
- map (\f -> I (fieldName $ getField f, GetField f (I $ Var 0))) fs))
+ , renderValues $ runExp [] $ TableView (AllItems cat) $
+ map (\f -> (fieldName $ getField f, GetField f (Var 0))) fs))
]
diff -rN -u old-fenserve/fendata/Rendering.hs new-fenserve/fendata/Rendering.hs
--- old-fenserve/fendata/Rendering.hs 2007-06-14 01:11:05.000000000 +0300
+++ new-fenserve/fendata/Rendering.hs 2007-06-14 01:11:05.000000000 +0300
@@ -8,11 +8,11 @@
import Utils
import Control.Monad
-import Control.Monad.Reader (ReaderT, ask, local)
+import Control.Monad.Reader (ReaderT, ask, asks, 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.Generics
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Typeable
@@ -46,32 +46,43 @@
renderValues vs = commaList $ map renderValue $ vs
-newtype Cx a = Cx (a, a -> Exp)
-type CxExp = Exp' Cx
+data Env = Env { envVars :: [(String,Type)], envPath :: [Int], envWhole :: Exp }
-instance Typeable1 Cx where
- typeOf1 (_ :: Cx a) = mkTyConApp (mkTyCon "Cx") []
-
-
-type RenderExp = ReaderT [(String,Type)] (StateT Int (Writer HTML))
+type RenderExp = ReaderT Env (StateT Int (Writer HTML))
varType :: (?db :: DB) => Int -> RenderExp ()
-varType i = ask >>= return . toHTML . renderType . snd . (!! i) >>= tell
+varType i = ask >>= tell . toHTML . renderType . snd . (!! i) . envVars
varName :: (?db :: DB, ?funs :: Map FunId Fun) => Int -> RenderExp ()
-varName i = fmap (!! i) ask >>= \(name,_) -> ren ("'", ital name, "'")
+varName i = asks ((!! i) . envVars) >>= \(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)
+mintVar t f = do var <- get; put (var + 1)
+ local (\e -> e {envVars=("v"++show var,t):envVars e}) (f var)
+
+focusPath :: Data a => [Int] -> a -> a
+focusPath [] = mkT Focus
+focusPath (p:ps) = snd . f 0 where
+ f i = gfoldl k (\x -> (i,x))
+ k :: Data a => (Int, a -> b) -> a -> (Int, b)
+ k (i,c) x = if typeOf x /= typeOf (undefined :: Exp) then fmap c (f i x)
+ else (i+1, c $ if i==p then focusPath ps x else x)
+
+expWithFocus :: RenderExp Exp
+expWithFocus = ask >>= \env -> return $ focusPath (envPath env) (envWhole env)
class RenderOne a where renderOne :: (?db :: DB, ?funs :: Map FunId Fun) => a -> RenderExp ()
+
+data E = E Int Exp
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)
+instance RenderOne E where
+ renderOne (E i e) =
+ local (\env -> env { envPath = envPath env ++ [i] }) (renderExp' e)
class Ren a where ren :: (?db :: DB, ?funs :: Map FunId Fun) => a -> RenderExp ()
@@ -80,31 +91,33 @@
ren t | (x,xs) <- tsplit1 t = renderOne x >> ren xs
-renderExp' :: (?db :: DB, ?funs :: Map FunId Fun) => CxExp -> RenderExp ()
+renderExp' :: (?db :: DB, ?funs :: Map FunId Fun) => Exp -> RenderExp ()
renderExp' (Var i) = ren ( varType i, " ", varName i )
-renderExp' (Call fun exps) = f template exps where
- f (TCons h x xs) (e:es) = ren (h, e, f xs es)
- f (TNil h) [] = ren (I h)
+renderExp' (Call fun exps) = f template 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 = ?funs Map.! fun
renderExp' (Literal vals) = ren ( I vals )
renderExp' (GetField field exp) = ren
- ( "the ", fieldName $ getField field, " of ", exp )
+ ( "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 o) = ren
- ( e1, " sorted by ", e2, ", ", case o of Ascending -> "ascending"
- Descending -> "descending" )
+renderExp' (Sort e1 e2 order) = ren
+ ( E 0 e1, " sorted by ", E 1 e2, ", ", case order 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
+ ( "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 ( e1, " ", f op, " ", e2 ) where
+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 ", 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' (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 exp )
+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-14 01:11:05.000000000 +0300
+++ new-fenserve/fendata/Types.hs 2007-06-14 01:11:05.000000000 +0300
@@ -144,26 +144,20 @@
data CmpOp = Lt | Le | Eq | Ge | Gt
deriving (Read, Show, Typeable, Data, Eq, Ord)
-data Typeable1 f => Exp' f = Var Int
- | Call FunId [f (Exp' f)]
- | Literal Values
- | GetField FieldId (f (Exp' f))
- | AllItems CategoryId
- | Sort (f (Exp' f)) (f (Exp' f)) Order
- | Filter BaseType (f (Exp' f)) (f (Exp' f))
- | NumOp NumOp (f (Exp' f)) (f (Exp' f))
- | CmpOp CmpOp (f (Exp' f)) (f (Exp' f))
- | Sum (f (Exp' f)) | Product (f (Exp' f)) | Count (f (Exp' f))
- | IfThenElse (f (Exp' f)) (f (Exp' f)) (f (Exp' f))
- | Today
- | TableView (f (Exp' f)) [f (String, Exp' f)]
+data Exp = Var Int
+ | Call FunId [Exp]
+ | Literal Values
+ | GetField FieldId Exp
+ | AllItems CategoryId
+ | Sort 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 (f (Exp' f))
- deriving (Read, Show, Data, Eq, Ord)
-
-instance Typeable1 f => Typeable (Exp' f) where
- typeOf (_ :: Exp' f) =
- mkTyConApp (mkTyCon "Exp'") [typeOf1 (undefined::f (Exp' f))]
-
-type Exp = Exp' I
+ | Question Type | Focus Exp
+ deriving (Read, Show, Typeable, Data, Eq, Ord)
More information about the Fencommits
mailing list