[Fencommits] fenserve: refactor potion rendering by returning a list instead of using a writer monad
Benja Fallenstein
benja.fallenstein at gmail.com
Wed Jun 20 18:18:56 EEST 2007
Wed Jun 20 18:18:44 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* refactor potion rendering by returning a list instead of using a writer monad
diff -rN -u old-fenserve/fendata/Potions.hs new-fenserve/fendata/Potions.hs
--- old-fenserve/fendata/Potions.hs 2007-06-20 18:18:56.000000000 +0300
+++ new-fenserve/fendata/Potions.hs 2007-06-20 18:18:56.000000000 +0300
@@ -9,7 +9,7 @@
import Rendering
import Control.Monad.Fix
-import Control.Monad.Reader (local, runReaderT)
+import Control.Monad.Reader (local, runReaderT, ask, asks)
import Control.Monad.State
import Control.Monad.Writer (execWriter)
@@ -96,27 +96,62 @@
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 i = ask >>= renderOne . renderType . snd . (!! i) . envVars
+
+varName :: (?db :: DB, ?time :: Int64) => Int -> RenderExp [(Bool, HTML)]
+varName i = asks ((!! i) . envVars) >>= \(name,_) -> ren ("'", ital name, "'")
+
+mintVar :: Type -> (Int -> RenderExp a) -> RenderExp a
+mintVar t f = do var <- get; put (var + 1)
+ local (\e -> e {envVars=(n var,t):envVars e}) (f var) where
+ n i = (if i<26 then "" else n (i `div` 26))
+ ++ [toEnum $ fromEnum 'a' + i `mod` 26]
+
+focusPath :: [Int] -> GenericT
+focusPath [] = mkT Focus
+focusPath (p:ps) = snd . f 0 where
+ f i = gfoldl k (\x -> (i,x))
+ k :: Data a => (Int, a -> b) -> a -> (Int, b)
+ k (i,c) x = if typeOf x /= typeOf (undefined :: Exp) then fmap c (f i x)
+ else (i+1, c $ if i==p then focusPath ps x else x)
+
+
data E = E Int Exp
instance RenderOne E where
- renderOne (E i e) =
- local (\env -> env { envPath = envPath env ++ [i] }) (renderExp' e)
+ renderOne (E i e) = do
+ path <- asks envPath; let path' = path ++ [i]
+ l <- local (\env -> env { envPath = path' }) (renderExp' e)
+ exp <- liftM (focusPath path') (asks envWhole)
+ return [(True, tag "span" [P "class" "potion"] $ joinPieces exp l)]
+
+instance RenderOne (RenderExp [(Bool, HTML)]) where renderOne m = m
+instance RenderOne Type where renderOne = renderOne . renderType
+instance RenderOne Values where renderOne = renderOne . renderValues
+instance ToHTML a => RenderOne a where
+ renderOne x = asks envPath >>= \p -> return [(False, toHTML x)]
+instance Ren () where ren () = return []
+instance (RenderOne x, Ren xs, Tuple x xs t) => Ren t where
+ ren t | (x,xs) <- tsplit1 t = liftM2 (++) (renderOne x) (ren xs)
+
renderExp :: (?db :: DB, ?time :: Int64) => Exp -> HTML
-renderExp exp = potion $ fst $ f [] (HTML "") $ execWriter $ flip runStateT 0 $ runReaderT (renderExp' exp) $ Env [] [] exp where
- potion = tag "span" [P "class" "potion"]
- lnk p = tag "a"
- [ P "class" "editLink"
- , P "href" $ "/potion/" ++ showExp (focusPath p exp) ]
-
- f p h ((q,i):(r,j):xs) | q == r = f p h ((q,i&j):xs)
- f p h ((q,i):xs) | p == q = f p (h & lnk p i) xs
- | p `isPrefixOf` q = let (i',xs') = f q (HTML "") ((q,i):xs)
- in f p (h & potion i') xs'
- f p h xs = (h,xs)
+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 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
+ [ P "class" "editLink"
+ , P "href" $ "/potion/" ++ showExp exp ]
+joinPieces exp [] = HTML ""
-renderExp' :: (?db :: DB, ?time :: Int64) => Exp -> RenderExp ()
+renderExp' :: (?db :: DB, ?time :: Int64) => Exp -> RenderExp [(Bool, HTML)]
renderExp' (Question ty) = ren ( "[which ", renderType ty, "?]" )
renderExp' (Focus exp) = ren ( I $ E 0 exp )
renderExp' exp@(Exp n arg) = f (getPotion n) where
diff -rN -u old-fenserve/fendata/Rendering.hs new-fenserve/fendata/Rendering.hs
--- old-fenserve/fendata/Rendering.hs 2007-06-20 18:18:56.000000000 +0300
+++ new-fenserve/fendata/Rendering.hs 2007-06-20 18:18:56.000000000 +0300
@@ -48,38 +48,3 @@
renderValues vs = commaList $ map renderValue $ vs
-
-varType :: (?db :: DB, ?time :: Int64) => Int -> RenderExp ()
-varType i = ask >>= renderOne . renderType . snd . (!! i) . envVars
-
-varName :: (?db :: DB, ?time :: Int64) => Int -> RenderExp ()
-varName i = asks ((!! i) . envVars) >>= \(name,_) -> ren ("'", ital name, "'")
-
-mintVar :: Type -> (Int -> RenderExp a) -> RenderExp a
-mintVar t f = do var <- get; put (var + 1)
- local (\e -> e {envVars=(n var,t):envVars e}) (f var) where
- n i = (if i<26 then "" else n (i `div` 26))
- ++ [toEnum $ fromEnum 'a' + i `mod` 26]
-
-focusPath :: [Int] -> GenericT
-focusPath [] = mkT Focus
-focusPath (p:ps) = snd . f 0 where
- f i = gfoldl k (\x -> (i,x))
- k :: Data a => (Int, a -> b) -> a -> (Int, b)
- k (i,c) x = if typeOf x /= typeOf (undefined :: Exp) then fmap c (f i x)
- else (i+1, c $ if i==p then focusPath ps x else x)
-
-expWithFocus :: RenderExp Exp
-expWithFocus = ask >>= \env -> return $ focusPath (envPath env) (envWhole env)
-
-
-instance RenderOne (RenderExp a) where renderOne m = m >> return ()
-instance RenderOne Type where renderOne = renderOne . renderType
-instance RenderOne Values where renderOne = renderOne . renderValues
-instance ToHTML a => RenderOne a where
- renderOne x = asks envPath >>= \p -> tell [(p, toHTML x)]
-
-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
-
diff -rN -u old-fenserve/fendata/Types.hs new-fenserve/fendata/Types.hs
--- old-fenserve/fendata/Types.hs 2007-06-20 18:18:56.000000000 +0300
+++ new-fenserve/fendata/Types.hs 2007-06-20 18:18:56.000000000 +0300
@@ -135,14 +135,16 @@
-- Potions
----------------------------------------------------------------------------
-class RenderOne a where renderOne :: (?db :: DB, ?time :: Int64) => a -> RenderExp ()
-
-class Ren a where ren :: (?db :: DB, ?time :: Int64) => a -> RenderExp ()
-
data Env = Env { envVars :: [(String,Type)], envPath :: [Int], envWhole :: Exp }
-type RenderExp = ReaderT Env :$$: StateT Int :$$: Writer [([Int], HTML)]
+type RenderExp = ReaderT Env :$$: State Int
+class RenderOne a where
+ renderOne :: (?db :: DB, ?time :: Int64) => a -> RenderExp [(Bool, HTML)]
+
+class Ren a where
+ ren :: (?db :: DB, ?time :: Int64) => a -> RenderExp [(Bool, HTML)]
+
data SExp = SExp String [SExp]
More information about the Fencommits
mailing list