[Fencommits] fenserve: a monad for renderExp
Benja Fallenstein
benja.fallenstein at gmail.com
Wed Jun 13 21:20:06 EEST 2007
Wed Jun 13 21:19:30 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* a monad for renderExp
diff -rN -u old-fenserve/fendata/HTML.hs new-fenserve/fendata/HTML.hs
--- old-fenserve/fendata/HTML.hs 2007-06-13 21:20:04.000000000 +0300
+++ new-fenserve/fendata/HTML.hs 2007-06-13 21:20:04.000000000 +0300
@@ -8,6 +8,7 @@
import Data.Generics (Typeable, Data)
import Data.Maybe (fromMaybe)
+import Data.Monoid
newtype HTML = HTML String deriving (Read, Show, Eq, Ord, Typeable, Data)
@@ -55,6 +56,10 @@
instance ToString String where toString = id
instance Show a => ToString a where toString = show
+
+instance Monoid HTML where
+ mempty = HTML ""
+ mappend = (&)
quoteBr = HTML . concatMap (\c -> case c of '\n' -> "<br>"; _ -> quoteChar c)
quoteP = HTML . concatMap (\c -> case c of '\n' -> "<p>"; _ -> quoteChar c)
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-06-13 21:20:04.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-06-13 21:20:04.000000000 +0300
@@ -33,8 +33,8 @@
case evaluate (html content) of
Right s -> s; Left e -> "Internal server error: " ++ show e
-runPost path target m = h (path :: [String]) POST $ seeOther $ \() () ->
- case evaluate (target, execState m ?state) of
+runPost path m = h (path :: [String]) POST $ seeOther $ \() () ->
+ case evaluate (runState m ?state) of
Right (uri,state') -> put state' >> respond (uri, uri)
Left e -> respond ("", "Internal server error: " ++ show e)
@@ -77,7 +77,7 @@
, para $ textarea "csv" 10 80 ""
, submit "Submit" ) )
- , runPost ["import"] "/table" $ do
+ , runPost ["import"] $ do
cat <- new_category $ lookE "catName"
let fieldNames : rows = parseCSV $ lookE "csv"
fields <- forM fieldNames $ \n -> new_field n cat $ Single InlineType
@@ -85,11 +85,12 @@
item <- new_item $ Set.singleton cat
forM_ (zip fields r) $ \(field, value) ->
modify $ u_value item field [InlineValue $ toHTML value]
+ return "/table"
, page ["table"] "Table"
( h2 "Table of all data in the database (if any)"
, catFor (Map.elems $ dbCategories ?db) $ \(Category cat name fs) ->
- ( h3 ("Category ", name)
- , renderValues $ runExp [] $ Exp $ TableView (Exp $ AllItems cat) $
- map (\f -> (fieldName $ getField f, Exp $ GetField f (Exp $ Var 0))) fs))
+ ( h3 ("Category: ", name)
+ , renderValues $ runExp [] $ I $ TableView (I $ AllItems cat) $
+ map (\f -> I (fieldName $ getField f, GetField f (I $ Var 0))) fs))
]
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-06-13 21:20:04.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-06-13 21:20:04.000000000 +0300
@@ -8,10 +8,13 @@
import Utils
import Control.Monad
+import Control.Monad.Reader (ReaderT, ask, local)
+import Control.Monad.State (StateT, get, put)
+import Control.Monad.Writer (Writer, tell)
import Data.Int (Int64)
import Data.List (sort)
-import Data.Generics (Typeable, everything, mkQ, extQ, gmapQr)
+import Data.Generics (Typeable, Typeable1, everything, mkQ, extQ, gmapQr)
import Data.Map (Map)
import qualified Data.Map as Map
@@ -84,6 +87,41 @@
renderValue (ItemValue _ i) = "Item " & show i -- XXX
renderValues vs = commaList $ map renderValue $ vs
+
+
+newtype Cx a = Cx (a, a -> Exp)
+type CxExp = Exp' Cx
+
+
+type RenderExp = ReaderT [(String,Type)] (StateT Int (Writer HTML))
+
+ren :: ToHTML a => a -> RenderExp ()
+ren x = tell (toHTML x)
+
+varType :: Int -> RenderExp Type
+varType i = fmap (snd . (!! i)) ask
+
+renderVar :: Int -> RenderExp ()
+renderVar i = fmap (!! i) ask >>= \(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)
+
+
+renderExp' :: (?db :: DB) => Exp -> RenderExp ()
+renderExp' (Var i) = do varType i -> ty; ren (renderType ty, " "); renderVar i
+--renderExp' (Call fun exps) = ...
+renderExp' (Literal vals) = ren $ renderValues vals
+renderExp' (GetField field (I exp)) =
+ ren ("the ", fieldName $ getField field, " of ") >> renderExp' exp
+renderExp' (AllItems cat) =
+ ren ("all the ", plural $ catName $ getCategory cat, " in the database")
+renderExp' (Sort (I e1) (I e2) order) =
+ renderExp' e1 >> ren " sorted by " >> renderExp' e2 >> ren (", ", f order)
+ where f Ascending = "ascending"; f Descending = "descending"
+renderExp' (Filter ty (I e1) (I e2)) = mintVar (Single ty) $ \var -> do
+ ren ("those ", renderType (Multiple ty), " ")
+ renderVar var; ren " "; renderExp' e1; ren " such that "; renderExp' e2
renderExp exp = zipHTML (map toHTML $ template exp) $ gmapQr (++) [] f exp where
@@ -102,7 +140,7 @@
++ " in the database"]
template (Sort _ _ order) = ["", " sorted by ", ", " ++ f order]
where f Ascending = "ascending"; f Descending = "descending"
- template (Filter _ _) = ["those of ", " such that ", ""]
+ template (Filter ty _ _) = ["those of ", " such that ", ""]
template (NumOp op _ _) = ["", " " ++ f op ++ " " , ""]
where f Add = "+"; f Subtract = "-"; f Mul = "*"; f Div = "/"
template (CmpOp op _ _) = ["", " " ++ f op ++ " " , ""]
@@ -122,11 +160,11 @@
----------------------------------------------------------------------------
runExp :: (?db :: DB, ?time :: Int64, ?funs :: Map FunId Fun) =>
- [Values] -> Exp -> Values
-runExp env = runExp' env . unExp
+ [Values] -> (I Exp) -> Values
+runExp env = runExp' env . unI
runExp' env (Var i) = env !! i
-runExp' env (Call fun exps) = runExp (map (runExp env) exps) body where
+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
@@ -137,7 +175,7 @@
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
@@ -158,7 +196,7 @@
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
+ ( tag "tr" [] $ catFor columns $ tag "th" [] . fst . unI
, catFor (runExp env exp) $ \item -> tag "tr" [] $
- catFor columns $ \(_,exp') ->
- tag "td" [] $ renderValues $ runExp ([item]:env) exp' )
+ catFor columns $ \(I (_,exp')) ->
+ tag "td" [] $ renderValues $ runExp' ([item]:env) exp' )
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs 2007-06-13 21:20:04.000000000 +0300
+++ new-fenserve/fendata/Types.hs 2007-06-13 21:20:04.000000000 +0300
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction #-}
+{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction -fallow-undecidable-instances #-}
module Types where
@@ -10,7 +10,7 @@
import Control.Monad.Reader (Reader)
import Control.Monad.State
-import Data.Generics (Typeable, Data)
+import Data.Generics -- (Typeable, Typeable1, Data)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
@@ -143,21 +143,29 @@
data CmpOp = Lt | Le | Eq | Ge | Gt
deriving (Read, Show, Typeable, Data, Eq, Ord)
-data Exp' e = Var Int
- | Call FunId [e]
+data Typeable1 f => Exp' f = Var Int
+ | Call FunId [f (Exp' f)]
| Literal Values
- | GetField FieldId e
+ | GetField FieldId (f (Exp' f))
| AllItems CategoryId
- | Sort e e Order
- | Filter e e
- | NumOp NumOp e e | CmpOp CmpOp e e
- | Sum e | Product e | Count e
- | IfThenElse e e e
+ | 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 e [(String, e)]
+ | TableView (f (Exp' f)) [f (String, Exp' f)]
- | Question Type | Focus e
- deriving (Read, Show, Typeable, Data, Eq, Ord)
+ | Question Type | Focus (f (Exp' f))
+ deriving (Read, Show, Data, Eq, Ord)
+
+newtype I a = I a deriving (Read, Show, Typeable, Data, Eq, Ord)
+unI (I x) = x
-newtype Exp = Exp { unExp :: Exp' Exp }
- deriving (Read, Show, Typeable, 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
+
More information about the Fencommits
mailing list