[Fencommits] fenserve: list possible replacements (except variables) for the focused subexpression on the potion edit page
Benja Fallenstein
benja.fallenstein at gmail.com
Mon Jun 25 00:42:57 EEST 2007
Mon Jun 25 00:42:42 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* list possible replacements (except variables) for the focused subexpression on the potion edit page
diff -rN -u old-fenserve/fendata/HTML.hs new-fenserve/fendata/HTML.hs
--- old-fenserve/fendata/HTML.hs 2007-06-25 00:42:57.000000000 +0300
+++ new-fenserve/fendata/HTML.hs 2007-06-25 00:42:57.000000000 +0300
@@ -89,6 +89,8 @@
h1 x = tag "h1" [] x; h2 x = tag "h2" [] x; h3 x = tag "h3" [] x
ul x = tag "ul" [] x; ol x = tag "ol" [] x; li x = tag "li" [] x
+ulist xs f = ul $ catMap (li . f) xs; olist xs f = ol $ catMap (li . f) xs
+
link href = tag "a" [P "href" href]
formG href = tag "form" [P "action" href, P "method" "GET"]
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-06-25 00:42:57.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-06-25 00:42:57.000000000 +0300
@@ -125,7 +125,8 @@
, renderValues $ runExp [] exp )
, h (Prefix ["edit"]) GET $ ok $ \[s] () -> respond $ either id id $
- evaluate $ html $ header & let exp = readExp $ unEscapeString s :: Exp in
+ evaluate $ html $ header & let exp = readExp $ unEscapeString s :: Exp
+ Just focus = getFocus exp in
( para $ tag' "small" $
link (impRoot ?imp ++ "potion/" ++ showExp (removeFocus exp))
"<< Back"
@@ -133,5 +134,6 @@
, hr
, para
( "The focused subexpression is of type '"
- , renderType $ expType $ case getFocus exp of Just x -> x, "'" ))
+ , renderType $ expType focus, ".' Possible replacements:" )
+ , ulist (expressionsOfType $ expType focus) renderExp )
]
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-06-25 00:42:57.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-06-25 00:42:57.000000000 +0300
@@ -17,6 +17,7 @@
import Data.Int
import Data.Generics
import Data.List
+import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe)
import System.Time
@@ -36,30 +37,45 @@
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) = case g $ fromJust $ cast arg of (_,_,r) -> r 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
+ f (Potion _ g) = case g (fromJust $ cast a) of (t,_,_,_) -> t
+
+
+expressionsOfType :: (?imp :: Imp) => Type -> [Exp]
+expressionsOfType ty = filter ((== ty) . expType) (concatMap f potions) where
+ f (Potion n g) = case g (errTuple $ "Bad dependency in potion '"++n++"'") of
+ (_,xs,_,_) -> map (Exp n) xs
+
+allValues :: (?imp :: Imp, Data a) => [a]
+allValues = otherCase `extR` baseTypes where
+ otherCase = fix $ \r -> do c <- dataTypeConstrs $ dataTypeOf $ head r
+ gunfold (\fs -> liftM2 ($) fs allValues) return c
+
potions =
[ Potion "var" $ \(ty, i) ->
( ty
+ , []
, ( renderType ty, " ", varName i )
, \env -> env !! i )
, Potion "literal" $ \(ty, values) ->
( ty
+ , []
, I $ renderValues values
, \env -> values )
-- XXX this should be handled by converting Funs to Potions:
, Potion "call" $ \(fn, args) ->
( 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
@@ -67,17 +83,22 @@
, Potion "getField" $ \(field, exp) ->
( ifMultiple [expType exp] $ fieldType $ getField field
+ , [ (fieldId field, Question $ Single $ ItemType $ fieldCat field)
+ | field <- Map.elems $ dbFields $ impDB ?imp]
, ( "the ", uncapitalize $ fieldName $ getField field, " of ", E 0 exp )
, \env -> do ItemValue _ item <- runExp env exp; getValue item field )
, Potion "allItems" $ \(I cat) ->
( Multiple (ItemType cat)
+ , [ I cat | cat <- Map.keys $ dbCategories $ impDB ?imp ]
, ( "all ", plural $ uncapitalize $ catName $ getCategory cat
, " in the database" )
, \_ -> map (ItemValue cat) $ map itemId $ getItems cat )
, Potion "sort" $ \(ty, e1, e2, order) ->
( Multiple ty
+ , [ (ty, Question (Multiple ty), Question (Single ty'), order)
+ | (ty,ty',order) <- allValues ]
, mint $ \var -> ( E 0 e1, " ", varName var, ", sorted by ", E 1 e2
, ", " , case order of Asc -> "ascending"
Desc -> "descending" )
@@ -88,6 +109,8 @@
, Potion "filter" $ \(ty, e1, e2) ->
( Multiple ty
+ , [ (ty, Question $ Multiple ty, Question $ Single $ BooleanType)
+ | ty <- allValues :: [BaseType] ]
, mint $ \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
@@ -95,6 +118,8 @@
, Potion "numOp" $ \(op, e1, e2) ->
( ifMultiple (map expType [e1,e2]) (Single NumberType)
+ , [ (op, Question $ Single $ NumberType, Question $ Single $ NumberType)
+ | op <- allValues]
, ( E 0 e1, " ", case op of Add->"+"; Subtract->"-"; Mul->"*"; Div->"/"
, " ", E 1 e2 )
, \env -> do NumberValue x <- runExp env e1
@@ -104,6 +129,7 @@
, Potion "cmpOp" $ \(op, e1, e2) ->
( ifMultiple (map expType [e1,e2]) (Single BooleanType)
+ , [ (op, Question ty, Question ty) | (op,ty) <- allValues ]
, ( E 0 e1, " ", case op of Lt->"<"; Le->"<="; Eq->"="; Ge->">="; Gt->">"
, " ", E 1 e2 )
, \env -> do x <- runExp env e1; y <- runExp env e2
@@ -112,33 +138,40 @@
, Potion "sum" $ \(I exp) ->
( Single NumberType
+ , [ I $ Question $ Multiple $ NumberType ]
, ( "the sum of ", E 0 exp )
, \env -> [NumberValue $ sum $ map numberValue $ runExp env exp] )
, Potion "product" $ \(I exp) ->
( Single NumberType
+ , [ I $ Question $ Multiple $ NumberType ]
, ( "the product of ", E 0 exp )
, \env -> [NumberValue $ product $ map numberValue $ runExp env exp] )
, Potion "count" $ \(I exp) ->
( Single NumberType
+ , [ I $ Question $ Multiple t | t <- allValues ]
, ( "the number of ", E 0 exp )
, \env -> [NumberValue $ fromIntegral $ length $ runExp env exp] )
, Potion "ifThenElse" $ \(e1, e2, e3) ->
( expType e2
+ , [ (Question $ Single BooleanType, Question t, Question t)
+ | t <- allValues ]
, ( "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" $ \() ->
( 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)]) ->
( Single BlockType
+ , []
, ( "A table of ", E 0 exp )
, \env -> return $ BlockValue $ tag "table" [P "border" "1"]
( tag "tr" [] $ catFor columns $ tag "th" [] . fst
diff -rN -u old-fenserve/fendata/Rendering.hs new-fenserve/fendata/Rendering.hs
--- old-fenserve/fendata/Rendering.hs 2007-06-25 00:42:57.000000000 +0300
+++ new-fenserve/fendata/Rendering.hs 2007-06-25 00:42:57.000000000 +0300
@@ -112,5 +112,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-25 00:42:57.000000000 +0300
+++ new-fenserve/fendata/Syntax.hs 2007-06-25 00:42:57.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 -> (Type, r, [Values] -> Values))) =
+ f (Potion _ (_ :: t -> (Type, [t], 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-25 00:42:57.000000000 +0300
+++ new-fenserve/fendata/Types.hs 2007-06-25 00:42:57.000000000 +0300
@@ -41,6 +41,10 @@
data BaseType = InlineType | BlockType | BooleanType | NumberType
| EmailType | WebLinkType | DateType | ItemType CategoryId
deriving (Read, Show, Typeable, Data, Eq, Ord)
+
+baseTypes = [ InlineType, BlockType, BooleanType, NumberType
+ , EmailType, WebLinkType, DateType ]
+ ++ [ ItemType c | c <- Map.keys $ dbCategories $ impDB ?imp ]
data Type = Single BaseType | Multiple BaseType
deriving (Read, Show, Typeable, Data, Eq, Ord)
@@ -168,7 +172,7 @@
----------------------------------------------------------------------------
data Potion = forall a r. (Data a, FromSExps a, ToSExps a, Ren r) =>
- Potion String (a -> (Type, r, [Values] -> Values))
+ Potion String (a -> (Type, [a], r, [Values] -> Values))
data Exp = forall a. (Data a, FromSExps a, ToSExps a) => Exp String a
| Question Type | Focus Exp
diff -rN -u old-fenserve/fendata/Utils.hs new-fenserve/fendata/Utils.hs
--- old-fenserve/fendata/Utils.hs 2007-06-25 00:42:57.000000000 +0300
+++ new-fenserve/fendata/Utils.hs 2007-06-25 00:42:57.000000000 +0300
@@ -5,9 +5,11 @@
import HAppS
import HTML
+import Control.Monad.Fix (fix)
import Control.Monad.State
import Data.Char (toUpper, toLower)
+import Data.Generics
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
import Data.Map (Map)
@@ -98,3 +100,6 @@
mdotted = cat . intersperse (" " & mdot & " ")
+errTuple :: Data a => String -> a
+errTuple s = fix $ \r -> fromConstrB (error s) $ indexConstr (dataTypeOf r) 1
+
More information about the Fencommits
mailing list