[Fencommits] fenserve: make renderExp more readable
Benja Fallenstein
benja.fallenstein at gmail.com
Wed Jun 13 22:11:27 EEST 2007
Wed Jun 13 22:11:15 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* make renderExp more readable
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-06-13 22:11:27.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-06-13 22:11:27.000000000 +0300
@@ -4,6 +4,7 @@
import Types
import HTML
import Utils
+import TupleUtils (I(I), fromI)
import CSV
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-06-13 22:11:27.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-06-13 22:11:27.000000000 +0300
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances #-}
module Potions where
@@ -17,12 +17,14 @@
import Data.Generics (Typeable, Typeable1, everything, mkQ, extQ, gmapQr)
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Typeable
import Text.Printf (printf)
import System.Time
+{-
class Typeable b => ToTemplate a b where template :: a -> Template b
instance (ToHTML h, Typeable a) => ToTemplate (Identity h) a where
template (Identity h) = TNil (toHTML h)
@@ -40,6 +42,7 @@
templateValues (TCons _ x tl) = x : templateValues tl
templateValues (TNil _) = []
+-}
{-
@@ -92,66 +95,61 @@
newtype Cx a = Cx (a, a -> Exp)
type CxExp = Exp' Cx
+instance Typeable1 Cx where
+ typeOf1 (_ :: Cx a) = mkTyConApp (mkTyCon "Cx") []
+
type RenderExp = ReaderT [(String,Type)] (StateT Int (Writer HTML))
-ren :: ToHTML a => a -> RenderExp ()
-ren x = tell (toHTML x)
+varType :: (?db :: DB) => Int -> RenderExp ()
+varType i = ask >>= return . toHTML . renderType . snd . (!! i) >>= tell
-varType :: Int -> RenderExp Type
-varType i = fmap (snd . (!! i)) ask
-
-renderVar :: Int -> RenderExp ()
-renderVar i = fmap (!! i) ask >>= \(name,_) -> ren ("'", ital name, "'")
+varName :: (?db :: DB) => Int -> RenderExp ()
+varName 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
- f :: (Typeable a) => a -> [HTML]
- f = mkQ [] (\e -> [renderExp e]) `extQ` (map renderExp)
+class RenderOne a where renderOne :: (?db :: DB) => a -> RenderExp ()
- template (Var i) = [renderType ty ++ " '" ++ name ++ "'"] where
- (name,ty) = ?env !! i
- template (Call fun _) = map html $ templateHTML tmp where
- Fun tmp _ _ = ?funs Map.! fun
- template (Literal vals) = [html $ renderValues vals]
- template (GetField field _) =
- ["the " ++ (fieldName $ getField field) ++ " of ", ""]
- template (AllItems cat) =
- ["all the " ++ (plural $ catName $ getCategory cat)
- ++ " in the database"]
- template (Sort _ _ order) = ["", " sorted by ", ", " ++ f order]
- where f Ascending = "ascending"; f Descending = "descending"
- 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 ++ " " , ""]
- where f Lt = "<"; f Le = "<="; f Eq = "="; f Ge = ">="; f Gt = ">"
- template (Sum _) = ["the sum of ", ""]
- template (Product _) = ["the product of ", ""]
- template (Count _) = ["the count of ", ""]
- template (IfThenElse _ _ _) = ["if ", " then ", " else ", ""]
- template Today = ["today's date"]
- template (Question ty) = ["[which " ++ renderType ty ++ "?]"]
- template (Focus _) = ["", ""]
+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)
+
+class Ren a where ren :: (?db :: DB) => a -> RenderExp ()
+
+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) => CxExp -> RenderExp ()
+renderExp' (Var i) = ren ( varType i, " ", varName i )
+--renderExp' (Call fun exps) =
+renderExp' (Literal vals) = ren ( I vals )
+renderExp' (GetField field exp) = ren
+ ( "the ", fieldName $ getField field, " of ", 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' (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
+ f Add = "+"; f Subtract = "-"; f Mul = "*"; f Div = "/"
+renderExp' (CmpOp op e1 e2) = ren ( e1, " ", f op, " ", 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' Today = ren ( I "today's date" )
+renderExp' (Question ty) = ren ( "[which ", ty, "?]" )
+renderExp' (Focus exp) = ren ( I exp )
@@ -161,7 +159,7 @@
runExp :: (?db :: DB, ?time :: Int64, ?funs :: Map FunId Fun) =>
[Values] -> (I Exp) -> Values
-runExp env = runExp' env . unI
+runExp env = runExp' env . fromI
runExp' env (Var i) = env !! i
runExp' env (Call fun exps) = runExp' (map (runExp env) exps) body where
@@ -196,7 +194,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 . unI
+ ( tag "tr" [] $ catFor columns $ tag "th" [] . fst . fromI
, catFor (runExp env exp) $ \item -> tag "tr" [] $
catFor columns $ \(I (_,exp')) ->
tag "td" [] $ renderValues $ runExp' ([item]:env) exp' )
diff -rN -u old-fenserve/fendata/TupleUtils.hs new-fenserve/fendata/TupleUtils.hs
--- old-fenserve/fendata/TupleUtils.hs 2007-06-13 22:11:27.000000000 +0300
+++ new-fenserve/fendata/TupleUtils.hs 2007-06-13 22:11:27.000000000 +0300
@@ -1,9 +1,9 @@
{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
module TupleUtils (Tuple(..), tsplit1, tsplit2, tsplit3,
- TAppend(..), Identity(..)) where
-
-import Control.Monad.Identity
+ TAppend(..), I(..), fromI) where
+
+import Data.Generics
infixr 5 .*.
@@ -20,6 +20,10 @@
tsplit3 :: (Tuple x yzt xyzt, Tuple y zt yzt, Tuple z t zt) => xyzt -> (x,y,z,t)
tsplit3 t = (thead t, thead $ ttail t, thead $ ttail $ ttail t, ttail $ ttail $ ttail t)
+
+
+newtype I a = I a deriving (Read, Show, Typeable, Data, Eq, Ord)
+fromI (I x) = x
class TAppend xs ys zs | xs ys -> zs, xs zs -> ys, ys zs -> xs where
@@ -30,15 +34,15 @@
tappend xxs ys | (x,xs) <- tsplit1 xxs = x .*. tappend xs ys
-instance Tuple a () (Identity a) where
- x .*. () = Identity x
- thead (Identity x) = x
- ttail (Identity _) = ()
+instance Tuple a () (I a) where
+ x .*. () = I x
+ thead (I x) = x
+ ttail (I _) = ()
-instance Tuple a (Identity b) (a,b) where
- x .*. Identity y = (x,y)
+instance Tuple a (I b) (a,b) where
+ x .*. I y = (x,y)
thead (x,y) = x
- ttail (x,y) = Identity y
+ ttail (x,y) = I y
{-
The following code is generated by this program:
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs 2007-06-13 22:11:27.000000000 +0300
+++ new-fenserve/fendata/Types.hs 2007-06-13 22:11:27.000000000 +0300
@@ -3,6 +3,7 @@
module Types where
import HTML
+import TupleUtils
import Utils
import HAppS (StartState, startStateM)
@@ -160,9 +161,6 @@
| 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
-
instance Typeable1 f => Typeable (Exp' f) where
typeOf (_ :: Exp' f) =
mkTyConApp (mkTyCon "Exp'") [typeOf1 (undefined::f (Exp' f))]
More information about the Fencommits
mailing list