[Fencommits] fenserve: refactor: move potion URI syntax code to own module, pass a record of implicit parameters rather than listing the parameters over and over again
Benja Fallenstein
benja.fallenstein at gmail.com
Wed Jun 20 20:22:25 EEST 2007
Wed Jun 20 20:21:16 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* refactor: move potion URI syntax code to own module, pass a record of implicit parameters rather than listing the parameters over and over again
diff -rN -u old-fenserve/fendata/Main.hs new-fenserve/fendata/Main.hs
--- old-fenserve/fendata/Main.hs 2007-06-20 20:22:25.000000000 +0300
+++ new-fenserve/fendata/Main.hs 2007-06-20 20:22:25.000000000 +0300
@@ -3,6 +3,7 @@
import Rendering
import Types
import HTML
+import Syntax
import Utils
import TupleUtils (I(I), fromI)
@@ -23,8 +24,9 @@
main = stdHTTP [ debugFilter
, h (Prefix ()) () $ \(path::[String]) req -> do
getTime -> time; get -> state :: DB
- let ?time = time; ?state = state; ?db = state; ?req = req
- ?funs = Map.empty
+ let imp = Imp { impTime = time, impDB = state,
+ impPotions = let ?imp=imp in potions }
+ let ?imp = imp; ?req = req; ?state = state
?root = concatMap (const "../") $ drop 1 path
runServerParts [app] req
]
@@ -108,7 +110,7 @@
, page ["table"] "Table"
( h2 "Table of all data in the database (if any)"
- , catFor (Map.elems $ dbCategories ?db) $ \(Category cat name fs) ->
+ , catFor (Map.elems $ dbCategories $ impDB ?imp) $ \(Category cat name fs) ->
( h3 ("Category: ", name)
, renderValues $ runExp [] $ Exp "tableView"
( Exp "allItems" (I cat)
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-06-20 20:22:25.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-06-20 20:22:25.000000000 +0300
@@ -6,6 +6,7 @@
import HTML
import Utils
import Types
+import Syntax
import Rendering
import Control.Monad.Fix
@@ -29,79 +30,22 @@
data Order = Asc | Desc
deriving (Read, Show, Typeable, Data, Eq, Ord)
-
-instance FromSExps () where fromSExps [] = ()
-instance (Tuple x xs xxs, Data x, FromSExps xs) => FromSExps xxs where
- fromSExps (x:xs) = fromSExp x .*. fromSExps xs
-
-instance ToSExps () where toSExps () = []
-instance (Tuple x xs xxs, Data x, ToSExps xs) => ToSExps xxs where
- toSExps xxs | (x,xs) <- tsplit1 xxs = toSExp x : toSExps xs
-
-fromSExp :: (?db :: DB, ?time :: Int64, Data a) => SExp -> a
-fromSExp = otherCase `extR` stringCase `extR` expCase where
- stringCase (SExp s []) = s
-
- expCase :: (?db :: DB, ?time :: Int64) => SExp -> Exp
- 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))) =
- Exp name (fromSExps args :: t)
-
- otherCase :: (?db :: DB, ?time :: Int64, Data a) => SExp -> a
- otherCase (SExp name args) = fix $ \r -> f (dataTypeOf r) where
- f t | name == "" && dataTypeName t == "Prelude.[]" =
- case args of [] -> otherCase (SExp "[]" [])
- (x:xs) -> otherCase (SExp "(:)" [x, SExp "" xs])
- f t = snd $ gunfold k (\x -> (args, x)) c where
- k (x:xs, f) = (xs, f $ fromSExp x)
- c | name == "" && maxConstrIndex t == 1 = indexConstr t 1
- | True = fromMaybe (error $ "not found: "++name) $ readConstr t name
-
-toSExp :: (?db :: DB, ?time :: Int64, Data a) => a -> SExp
-toSExp = otherCase `extQ` stringCase `extQ` expCase where
- stringCase s = SExp s []
-
- expCase :: (?db :: DB, ?time :: Int64) => Exp -> SExp
- expCase (Exp name args) = SExp name (toSExps args)
- expCase (Question ty) = SExp "question" [toSExp ty]
- expCase (Focus exp) = SExp "focus" [toSExp exp]
-
- otherCase :: (?db :: DB, ?time :: Int64, Data a) => a -> SExp
- otherCase x = SExp (showConstr (toConstr x)) (gmapQ toSExp x)
-
-readExp = fromSExp . head . fst . f z where
- z = SExp "" []; f e "" = ([e], ""); f e (')':cs) = ([e], cs)
- f (SExp n xs) ('(':cs) = let (xs',cs') = f z cs in f (SExp n (xs++xs')) cs'
- f e (',':cs) = let (xs,cs') = f z cs in (e:xs,cs')
- f (SExp n xs) ('\\':c:cs) = f (SExp (n++[c]) xs) cs
- f (SExp n xs) (c:cs) = f (SExp (n++[c]) xs) cs
-
-showExp = f . toSExp where
- f (SExp n []) = e n
- f (SExp n xs) = e n ++ "(" ++ (concat $ intersperse "," $ map f xs) ++ ")"
- e (c:cs) | c `elem` "\\(,)" = '\\' : c : e cs | otherwise = c : e cs
- e [] = []
mint ty (f, exec) = (I $ mintVar ty $ \var -> ren (f var), exec)
-runExp :: (?db :: DB, ?time :: Int64) => [Values] -> Exp -> Values
+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
-getPotion :: (?db :: DB, ?time :: Int64) => String -> Potion
-getPotion name = case filter (\(Potion n _) -> n == name) potions of
- (p:_) -> p; [] -> error $ "Potion not found: " ++ name
-varType :: (?db :: DB, ?time :: Int64) => Int -> RenderExp [(Bool, HTML)]
+varType :: (?imp :: Imp) => Int -> RenderExp [(Bool, HTML)]
varType i = ask >>= renderOne . renderType . snd . (!! i) . envVars
-varName :: (?db :: DB, ?time :: Int64) => Int -> RenderExp [(Bool, HTML)]
+varName :: (?imp :: Imp) => Int -> RenderExp [(Bool, HTML)]
varName i = asks ((!! i) . envVars) >>= \(name,_) -> ren ("'", ital name, "'")
mintVar :: Type -> (Int -> RenderExp a) -> RenderExp a
@@ -139,11 +83,11 @@
ren t | (x,xs) <- tsplit1 t = liftM2 (++) (renderOne x) (ren xs)
-renderExp :: (?db :: DB, ?time :: Int64) => Exp -> HTML
+renderExp :: (?imp :: Imp) => Exp -> HTML
renderExp exp = tag "span" [P "class" "potion"] $ joinPieces (Focus exp)
$ flip evalState 0 $ runReaderT (renderExp' exp) $ Env [] [] exp
-joinPieces :: (?db :: DB, ?time :: Int64) => Exp -> [(Bool,HTML)] -> HTML
+joinPieces :: (?imp :: Imp) => Exp -> [(Bool,HTML)] -> HTML
joinPieces exp ((False,h):(False,i):xs) = joinPieces exp ((False,h&i):xs)
joinPieces exp ((True,h):xs) = h & joinPieces exp xs
joinPieces exp ((False,h):xs) = (& joinPieces exp xs) $ flip (tag "a") h
@@ -151,9 +95,9 @@
, P "href" $ "/potion/" ++ showExp exp ]
joinPieces exp [] = HTML ""
-renderExp' :: (?db :: DB, ?time :: Int64) => Exp -> RenderExp [(Bool, HTML)]
+renderExp' :: (?imp :: Imp) => Exp -> RenderExp [(Bool, HTML)]
renderExp' (Question ty) = ren ( "[which ", renderType ty, "?]" )
-renderExp' (Focus exp) = do h <- liftM (catMap snd) $ renderOne $ E 0 exp
+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
@@ -232,7 +176,7 @@
, Potion "today" $ \() ->
( I "today's date"
- , \env -> let t = toUTCTime (TOD (fromIntegral ?time) 0)
+ , \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)]) ->
diff -rN -u old-fenserve/fendata/Syntax.hs new-fenserve/fendata/Syntax.hs
--- old-fenserve/fendata/Syntax.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/fendata/Syntax.hs 2007-06-20 20:22:25.000000000 +0300
@@ -0,0 +1,67 @@
+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances -fno-monomorphism-restriction #-}
+
+module Syntax where
+
+import TupleUtils
+import Types
+
+import Control.Monad.Fix (fix)
+
+import Data.Generics
+import Data.List (intersperse)
+import Data.Maybe (fromMaybe)
+
+instance FromSExps () where fromSExps [] = ()
+instance (Tuple x xs xxs, Data x, FromSExps xs) => FromSExps xxs where
+ fromSExps (x:xs) = fromSExp x .*. fromSExps xs
+
+instance ToSExps () where toSExps () = []
+instance (Tuple x xs xxs, Data x, ToSExps xs) => ToSExps xxs where
+ toSExps xxs | (x,xs) <- tsplit1 xxs = toSExp x : toSExps xs
+
+fromSExp :: (?imp :: Imp, Data a) => SExp -> a
+fromSExp = otherCase `extR` stringCase `extR` expCase where
+ stringCase (SExp s []) = s
+
+ expCase :: SExp -> Exp
+ 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))) =
+ Exp name (fromSExps args :: t)
+
+ otherCase :: Data a => SExp -> a
+ otherCase (SExp name args) = fix $ \r -> f (dataTypeOf r) where
+ f t | name == "" && dataTypeName t == "Prelude.[]" =
+ case args of [] -> otherCase (SExp "[]" [])
+ (x:xs) -> otherCase (SExp "(:)" [x, SExp "" xs])
+ f t = snd $ gunfold k (\x -> (args, x)) c where
+ k (x:xs, f) = (xs, f $ fromSExp x)
+ c | name == "" && maxConstrIndex t == 1 = indexConstr t 1
+ | True = fromMaybe (error $ "not found: "++name) $ readConstr t name
+
+toSExp :: (?imp :: Imp, Data a) => a -> SExp
+toSExp = otherCase `extQ` stringCase `extQ` expCase where
+ stringCase s = SExp s []
+
+ expCase :: Exp -> SExp
+ expCase (Exp name args) = SExp name (toSExps args)
+ expCase (Question ty) = SExp "question" [toSExp ty]
+ expCase (Focus exp) = SExp "focus" [toSExp exp]
+
+ otherCase :: Data a => a -> SExp
+ otherCase x = SExp (showConstr (toConstr x)) (gmapQ toSExp x)
+
+readExp = fromSExp . head . fst . f z where
+ z = SExp "" []; f e "" = ([e], ""); f e (')':cs) = ([e], cs)
+ f (SExp n xs) ('(':cs) = let (xs',cs') = f z cs in f (SExp n (xs++xs')) cs'
+ f e (',':cs) = let (xs,cs') = f z cs in (e:xs,cs')
+ f (SExp n xs) ('\\':c:cs) = f (SExp (n++[c]) xs) cs
+ f (SExp n xs) (c:cs) = f (SExp (n++[c]) xs) cs
+
+showExp = f . toSExp where
+ f (SExp n []) = e n
+ f (SExp n xs) = e n ++ "(" ++ (concat $ intersperse "," $ map f xs) ++ ")"
+ e (c:cs) | c `elem` "\\(,)" = '\\' : c : e cs | otherwise = c : e cs
+ e [] = []
+
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs 2007-06-20 20:22:25.000000000 +0300
+++ new-fenserve/fendata/Types.hs 2007-06-20 20:22:25.000000000 +0300
@@ -21,6 +21,13 @@
----------------------------------------------------------------------------
+-- Environment passed as implicit parameter
+----------------------------------------------------------------------------
+
+data Imp = Imp { impDB :: DB, impTime :: Int64, impPotions :: [Potion] }
+
+
+----------------------------------------------------------------------------
-- Data
----------------------------------------------------------------------------
@@ -76,14 +83,14 @@
-- Accessor and update functions
----------------------------------------------------------------------------
-getCategory cat = dbCategories ?db Map.! cat
-getField field = dbFields ?db Map.! field
-getItem item = dbItems ?db Map.! item
+getCategory cat = dbCategories (impDB ?imp) Map.! cat
+getField field = dbFields (impDB ?imp) Map.! field
+getItem item = dbItems (impDB ?imp) Map.! item
getValue item field = let Item _ _ vs = getItem item in vs Map.! field
-getFn fn = dbFunctions ?db Map.! fn
+getFn fn = dbFunctions (impDB ?imp) Map.! fn
getItems catId = filter (Set.member catId . itemCategories)
- (Map.elems (dbItems ?db))
+ (Map.elems (dbItems (impDB ?imp)))
u_catName f (Category a b c) = Category a (f b) c
u_catFields f (Category a b c) = Category a b (f c)
@@ -140,16 +147,16 @@
type RenderExp = ReaderT Env :$$: State Int
class RenderOne a where
- renderOne :: (?db :: DB, ?time :: Int64) => a -> RenderExp [(Bool, HTML)]
+ renderOne :: (?imp :: Imp) => a -> RenderExp [(Bool, HTML)]
class Ren a where
- ren :: (?db :: DB, ?time :: Int64) => a -> RenderExp [(Bool, HTML)]
+ ren :: (?imp :: Imp) => a -> RenderExp [(Bool, HTML)]
data SExp = SExp String [SExp]
-class FromSExps a where fromSExps :: (?db :: DB, ?time :: Int64) => [SExp] -> a
-class ToSExps a where toSExps :: (?db :: DB, ?time :: Int64) => a -> [SExp]
+class FromSExps a where fromSExps :: (?imp :: Imp) => [SExp] -> a
+class ToSExps a where toSExps :: (?imp :: Imp) => a -> [SExp]
data Potion = forall a r. (Data a, FromSExps a, ToSExps a, Ren r) =>
Potion String (a -> (r, [Values] -> Values))
@@ -163,6 +170,11 @@
deriving (Read, Show, Typeable, Data, Eq, Ord)
+getPotion :: (?imp :: Imp) => String -> Potion
+getPotion name = case filter (\(Potion n _) -> n == name) (impPotions ?imp) of
+ (p:_) -> p; [] -> error $ "Potion not found: " ++ name
+
+
expTy = mkDataType "Types.Exp" [cExp, cQuestion, cFocus]
constr s = mkConstr expTy s [] Prefix
cExp = constr "Exp"; cQuestion = constr "Question"; cFocus = constr "Focus"
More information about the Fencommits
mailing list