From e328706afeb684c174603168120f834fa48994f5 Mon Sep 17 00:00:00 2001
From: Brandon Bickford <bickfordb@gmail.com>
Date: Sat, 18 Jul 2009 03:18:49 -0700
Subject: [PATCH] switch to WriterT to emit template output

---
 Text/Press/Render.hs | 24 +++++++++++++-----------
 Text/Press/Run.hs    |  5 +++--
 Text/Press/Types.hs  | 13 ++++++++++---
 3 files changed, 26 insertions(+), 16 deletions(-)

diff --git a/Text/Press/Render.hs b/Text/Press/Render.hs
index 36da5fe..4d0ce0a 100644
--- a/Text/Press/Render.hs
+++ b/Text/Press/Render.hs
@@ -1,6 +1,8 @@
 module Text.Press.Render where
 
 import Control.Monad.State
+import Control.Monad.Writer.Lazy
+
 import Data.Map (Map, lookup, fromList, insert)
 import Data.Maybe (listToMaybe, catMaybes)
 import Prelude hiding (lookup)
@@ -11,11 +13,11 @@ import Text.JSON
 import Text.Press.Types
 
 instance Render Node where 
-    render (Text s) = return s 
+    render (Text s) = tell [s]
     render (Var var) = do
-        context <- get
+        context <- getRenderState
         case lookupVar var context of
-            Nothing -> return ""
+            Nothing -> tell [""]
             Just jsval -> renderJS jsval
     render (Tag _ f) = render f 
 
@@ -29,17 +31,18 @@ getf name (JSObject a) = get_field a name
 getf name otherwise = Nothing
 
 -- Show a block
+showBlock :: String -> RenderT_ 
 showBlock blockName = do
     templates <- templateStack
     let maybeNodes = lookupFirst blockName $ map tmplBlocks $ templates
     case maybeNodes of
-        Just nodes -> fmap (foldl (++) "") $ mapM render nodes
-        Nothing -> return ""
+        Just nodes -> mapM_ render nodes
+        Nothing -> tell [""]
 
 lookupFirst :: Ord k => k -> [Map k a] -> Maybe a
 lookupFirst name maps = listToMaybe . catMaybes $ map (lookup name) maps 
 
-getTemplate = fmap renderStateTemplate get
+getTemplate = fmap renderStateTemplate getRenderState
 
 templateStack = getTemplate >>= templateStack' 
     where
@@ -52,11 +55,10 @@ templateStack = getTemplate >>= templateStack'
                     return $ t : (template : templates)
                 Nothing -> liftIO $ error $ "expecting a template"
 
-renderJS JSNull = return ""
-renderJS (JSString x) = return $ fromJSString x
-renderJS other = return $ (showJSValue other) ""
+renderJS JSNull = tell [""]
+renderJS (JSString x) = tell [fromJSString x]
+renderJS other = tell [(showJSValue other) ""]
 
 doRender = do 
     bodyNodes <- fmap (tmplNodes . last) templateStack
-    st <- get
-    fmap (foldl (++) "") $ mapM render bodyNodes
+    mapM render bodyNodes
diff --git a/Text/Press/Run.hs b/Text/Press/Run.hs
index fa1c70c..2a94210 100644
--- a/Text/Press/Run.hs
+++ b/Text/Press/Run.hs
@@ -1,6 +1,7 @@
 module Text.Press.Run where
 
 import Control.Monad.State
+import Control.Monad.Writer.Lazy
 import Prelude hiding (lookup)
 
 import Data.Data (Data)
@@ -31,7 +32,7 @@ runJSONWithPath datas templateName = do
         renderStateTemplate = template,
         renderStateValues = datas
     }
-    liftIO $ evalStateT doRender st 
+    fmap (foldl (++) "") $ liftIO $ evalStateT (execWriterT doRender) st 
 
 runJSONWithBody :: [JSValue] -> String -> IO String
 runJSONWithBody jsvalues body = do 
@@ -47,7 +48,7 @@ runJSONWithTemplate' jsvalues template = do
         Just s -> addToTemplateCache s
         Nothing -> return ()
     parser <- get
-    liftIO $ evalStateT doRender $ RenderState {
+    fmap (foldl (++) "") $ liftIO $ evalStateT (execWriterT doRender) RenderState {
         renderStateParser = parser,
         renderStateTemplate = template,
         renderStateValues = jsvalues
diff --git a/Text/Press/Types.hs b/Text/Press/Types.hs
index 4e4a634..96a36b6 100644
--- a/Text/Press/Types.hs
+++ b/Text/Press/Types.hs
@@ -1,6 +1,9 @@
 module Text.Press.Types where 
 
 import Control.Monad.State (StateT)
+import Control.Monad.Trans (lift)
+import Control.Monad.State (get)
+import Control.Monad.Writer.Lazy (WriterT)
 import Data.Map (Map, lookup, fromList)
 import qualified Text.Parsec.Prim as Prim
 import Text.Parsec.Pos (SourcePos)
@@ -12,9 +15,13 @@ data RenderState = RenderState {
     renderStateValues :: [JSValue]
 }
 
-type RenderT = StateT RenderState IO
+type RenderT a = WriterT [String] (StateT RenderState IO) a
+type RenderT_ = RenderT ()
 
-data TagFunc = TagFunc (RenderT String)
+getRenderState :: RenderT RenderState
+getRenderState = lift $ get
+
+data TagFunc = TagFunc RenderT_
 
 data Node = Var String
     | Tag TagName TagFunc
@@ -63,7 +70,7 @@ data Parser = Parser {
 } deriving (Show)
 
 class Render a where
-    render :: a -> RenderT String
+    render :: a -> RenderT_
 
 newParser = Parser (fromList []) [] (fromList [])