[Fencommits] fenserve: add code to get the type of an expression
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Jun 21 15:58:57 EEST 2007
Thu Jun 21 15:53:03 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* add code to get the type of an expression
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-06-21 15:58:56.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-06-21 15:58:56.000000000 +0300
@@ -31,41 +31,54 @@
deriving (Read, Show, Typeable, Data, Eq, Ord)
-mint ty (f, exec) = (I $ mintVar ty $ \var -> ren (f var), exec)
+mint ty (t, f, exec) = (t, I $ mintVar ty $ \var -> ren (f var), exec)
runExp :: (?imp :: Imp) => [Values] -> Exp -> Values
runExp env (Focus e) = runExp env e
runExp env (Exp name arg) = f (getPotion name) where
- f (Potion _ g) = snd (g $ fromJust $ cast arg) env
+ f (Potion _ g) = case g $ fromJust $ cast arg of (_,_,r) -> r env
+
+
+expType :: (?imp :: Imp) => Exp -> Type
+expType (Question ty) = ty
+expType (Focus e) = expType e
+expType (Exp n a) = f (getPotion n) where
+ f (Potion _ g) = case g (fromJust $ cast a) of (t,_,_) -> t
potions =
- [ Potion "var" $ \(I i) ->
- ( ( varType i, " ", varName i )
+ [ Potion "var" $ \(ty, i) ->
+ ( ty
+ , ( varType i, " ", varName i )
, \env -> env !! i )
- , Potion "literal" $ \(I values) ->
- ( I $ renderValues values
+ , Potion "literal" $ \(ty, values) ->
+ ( ty
+ , I $ renderValues values
, \env -> values )
-- 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))
+ ( fnResult (getFn fn)
+ , 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 ", uncapitalize $ fieldName $ getField field, " of ", E 0 exp )
+ ( ifMultiple [expType exp] $ fieldType $ getField field
+ , ( "the ", uncapitalize $ fieldName $ getField field, " of ", E 0 exp )
, \env -> do ItemValue _ item <- runExp env exp; getValue item field )
, Potion "allItems" $ \(I cat) ->
- ( ( "all ", plural $ uncapitalize $ catName $ getCategory cat
+ ( Multiple (ItemType cat)
+ , ( "all ", plural $ uncapitalize $ 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 var, ", sorted by ", E 1 e2, ", "
+ ( Multiple ty
+ , \var -> ( E 0 e1, " ", varName var, ", sorted by ", E 1 e2, ", "
, case order of Asc -> "ascending"; Desc -> "descending" )
, \env -> let values = runExp env e1
sortKeys = map (\v -> runExp ([v]:env) e2) values
@@ -73,13 +86,15 @@
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
+ ( Multiple 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->"/"
+ ( ifMultiple (map expType [e1,e2]) (Single NumberType)
+ , ( 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
@@ -87,36 +102,43 @@
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->">"
+ ( ifMultiple (map expType [e1,e2]) (Single BooleanType)
+ , ( 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" $ \(I exp) ->
- ( ( "the sum of ", E 0 exp )
+ ( Single NumberType
+ , ( "the sum of ", E 0 exp )
, \env -> [NumberValue $ sum $ map numberValue $ runExp env exp] )
, Potion "product" $ \(I exp) ->
- ( ( "the product of ", E 0 exp )
+ ( Single NumberType
+ , ( "the product of ", E 0 exp )
, \env -> [NumberValue $ product $ map numberValue $ runExp env exp] )
, Potion "count" $ \(I exp) ->
- ( ( "the number of ", E 0 exp )
+ ( Single NumberType
+ , ( "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 )
+ ( expType e2
+ , ( "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"
+ ( Single DateType
+ , I "today's date"
, \env -> let t = toUTCTime (TOD (fromIntegral $ impTime ?imp) 0)
in [DateValue (ctYear t) (fromEnum (ctMonth t)+1) (ctDay t)] )
, Potion "tableView" $ \(exp, columns :: [(String,Exp)]) ->
- ( ( "A table of ", E 0 exp )
+ ( Single BlockType
+ , ( "A table of ", E 0 exp )
, \env -> return $ BlockValue $ tag "table" [P "border" "1"]
( tag "tr" [] $ catFor columns $ tag "th" [] . fst
, catFor (runExp env exp) $ \item -> tag "tr" [] $
diff -rN -u old-fenserve/fendata/Rendering.hs new-fenserve/fendata/Rendering.hs
--- old-fenserve/fendata/Rendering.hs 2007-06-21 15:58:56.000000000 +0300
+++ new-fenserve/fendata/Rendering.hs 2007-06-21 15:58:56.000000000 +0300
@@ -113,5 +113,5 @@
renderExp' (Focus exp) = do h <- liftM2 joinPieces (asks envWhole) $ renderExp' exp
return [(True, tag "span" [P "class" "focus"] h)]
renderExp' exp@(Exp n arg) = f (getPotion n) where
- f (Potion _ f) = let (r,_) = f (fromMaybe (error "renderExp") $ cast arg) in ren r
+ f (Potion _ f) = let (_,r,_) = f (fromMaybe (error "renderExp") $ cast arg) in ren r
diff -rN -u old-fenserve/fendata/Syntax.hs new-fenserve/fendata/Syntax.hs
--- old-fenserve/fendata/Syntax.hs 2007-06-21 15:58:56.000000000 +0300
+++ new-fenserve/fendata/Syntax.hs 2007-06-21 15:58:56.000000000 +0300
@@ -27,7 +27,7 @@
expCase (SExp "question" [ty]) = Question (fromSExp ty)
expCase (SExp "focus" [exp]) = Focus (fromSExp exp)
expCase (SExp name args) = f (getPotion name) where
- f (Potion _ (_ :: t -> (r, [Values] -> Values))) =
+ f (Potion _ (_ :: t -> (Type, r, [Values] -> Values))) =
Exp name (fromSExps args :: t)
otherCase :: Data a => SExp -> a
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs 2007-06-21 15:58:56.000000000 +0300
+++ new-fenserve/fendata/Types.hs 2007-06-21 15:58:56.000000000 +0300
@@ -43,6 +43,11 @@
data Type = Single BaseType | Multiple BaseType
deriving (Read, Show, Typeable, Data, Eq, Ord)
+
+ifMultiple :: [Type] -> Type -> Type
+ifMultiple (Multiple _:_) (Single t) = Multiple t
+ifMultiple (Single _:ts) t = ifMultiple ts t
+ifMultiple _ t = t
data Value = InlineValue HTML
| BlockValue HTML
@@ -162,7 +167,7 @@
----------------------------------------------------------------------------
data Potion = forall a r. (Data a, FromSExps a, ToSExps a, Ren r) =>
- Potion String (a -> (r, [Values] -> Values))
+ Potion String (a -> (Type, r, [Values] -> Values))
data Exp = forall a. (Data a, FromSExps a, ToSExps a) => Exp String a
| Question Type | Focus Exp
More information about the Fencommits
mailing list