Moved all StringTemplate support to own module

Test/QuasiResource.hs

@@ -4,7 +4,6 @@
 module Test.QuasiResource (testSuite) where
 
 import Yesod
-import Text.StringTemplate (nullGroup)
 import Test.Framework (testGroup, Test)
 import Test.Framework.Providers.HUnit
 import Test.HUnit hiding (Test)
@@ -67,7 +66,7 @@ ph ss h = do
         rr = error "No raw request"
         y = MyYesod
         cts = [TypeHtml]
-    res <- runHandler h eh rr y nullGroup cts
+    res <- runHandler h eh rr y cts
     res' <- myShow res
     mapM_ (helper res') ss
       where

Yesod/Handler.hs

@@ -38,7 +38,6 @@ module Yesod.Handler
 
 import Yesod.Request
 import Yesod.Response
-import Yesod.Template
 import Web.Mime
 
 import Control.Exception hiding (Handler)
@@ -52,9 +51,11 @@ import System.IO
 import Data.Object.Html
 import qualified Data.ByteString.Lazy as BL
 
+data HandlerData yesod = HandlerData RawRequest yesod
+
 ------ Handler monad
 newtype Handler yesod a = Handler {
-    unHandler :: (RawRequest, yesod, TemplateGroup)
+    unHandler :: HandlerData yesod
               -> IO ([Header], HandlerContents a)
 }
 data HandlerContents a =
@@ -83,32 +84,29 @@ instance MonadIO (Handler yesod) where
 instance Exception e => Failure e (Handler yesod) where
     failure e = Handler $ \_ -> return ([], HCError $ InternalError $ show e)
 instance RequestReader (Handler yesod) where
-    getRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr)
+    getRawRequest = Handler $ \(HandlerData rr _)
+                        -> return ([], HCContent rr)
     invalidParams = invalidArgs . map helper where
         helper ((_pt, pn, _pvs), e) = (pn, show e)
 
 getYesod :: Handler yesod yesod
-getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod)
+getYesod = Handler $ \(HandlerData _ yesod) -> return ([], HCContent yesod)
-
-instance HasTemplateGroup (Handler yesod) where
-    getTemplateGroup = Handler $ \(_, _, tg) -> return ([], HCContent tg)
 
 runHandler :: Handler yesod ChooseRep
            -> (ErrorResponse -> Handler yesod ChooseRep)
            -> RawRequest
            -> yesod
-           -> TemplateGroup
            -> [ContentType]
            -> IO Response
-runHandler (Handler handler) eh rr y tg cts = do
+runHandler handler eh rr y cts = do
     let toErrorHandler =
             InternalError
           . (show :: Control.Exception.SomeException -> String)
     (headers, contents) <- Control.Exception.catch
-        (handler (rr, y, tg))
+        (unHandler handler $ HandlerData rr y)
         (\e -> return ([], HCError $ toErrorHandler e))
     let handleError e = do
-            Response _ hs ct c <- runHandler (eh e) safeEh rr y tg cts
+            Response _ hs ct c <- runHandler (eh e) safeEh rr y cts
             let hs' = headers ++ hs
             return $ Response (getStatus e) hs' ct c
     let sendFile' ct fp = do

Yesod/Template.hs

@@ -1,71 +1,59 @@
--- FIXME this whole module needs to be rethought
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 module Yesod.Template
-    ( HasTemplateGroup (..)
+    ( YesodTemplate (..)
     , template
     , NoSuchTemplate
+    , Template
     , TemplateGroup
-    , Template (..)
-    , TemplateFile (..)
     ) where
 
 import Data.Object.Html
 import Data.Typeable (Typeable)
 import Control.Exception (Exception)
-import Control.Failure
 import Data.Object.Text (Text)
 import Text.StringTemplate
 import Data.Object.Json
 import Web.Mime
 import Yesod.Response
+import Yesod.Yesod
+import Yesod.Handler
+import Control.Monad (foldM)
+import Data.ByteString.Lazy (toChunks)
 
+type Template = StringTemplate Text
 type TemplateGroup = STGroup Text
 
-class HasTemplateGroup a where
+class Yesod y => YesodTemplate y where
-    getTemplateGroup :: a TemplateGroup
+    getTemplateGroup :: y -> TemplateGroup
 
-template :: (MonadFailure NoSuchTemplate t, HasTemplateGroup t)
+getTemplateGroup' :: YesodTemplate y => Handler y TemplateGroup
+getTemplateGroup' = getTemplateGroup `fmap` getYesod
+
+template :: YesodTemplate y
          => String -- ^ template name
-         -> String -- ^ object name
          -> HtmlObject -- ^ object
-         -> IO [(String, HtmlObject)] -- ^ template attributes
+         -> (HtmlObject -> Template -> IO Template)
-         -> t Template
+         -> Handler y ChooseRep
-template tn on o attrs = do
+template tn ho f = do
-    tg <- getTemplateGroup
+    tg <- getTemplateGroup'
     t <- case getStringTemplate tn tg of
             Nothing -> failure $ NoSuchTemplate tn
             Just x -> return x
-    return $ Template t on o attrs
+    return $ chooseRep
+        [ (TypeJson, cs $ unJsonDoc $ cs ho)
+        , (TypeHtml, tempToContent t ho f)
+        ]
 newtype NoSuchTemplate = NoSuchTemplate String
     deriving (Show, Typeable)
 instance Exception NoSuchTemplate
 
-data Template = Template (StringTemplate Text)
+tempToContent :: Template
-                         String
+              -> HtmlObject
-                         HtmlObject
+              -> (HtmlObject -> Template -> IO Template)
-                         (IO [(String, HtmlObject)])
+              -> Content
-instance HasReps Template where
+tempToContent t ho f = ioTextToContent $ fmap render $ f ho t
-    chooseRep = defChooseRep [ (TypeHtml,
-              \(Template t name ho attrsIO) -> do
-                attrs <- attrsIO
-                return
-                    $ cs
-                    $ render
-                    $ setAttribute name ho
-                    $ setManyAttrib attrs t)
-           , (TypeJson, \(Template _ _ ho _) ->
-                            return $ cs $ unJsonDoc $ cs ho)
-           ]
 
-data TemplateFile = TemplateFile FilePath HtmlObject
+ioTextToContent :: IO Text -> Content
-instance HasReps TemplateFile where
+ioTextToContent iotext = Content $ \f a -> iotext >>= \t ->
-    chooseRep = defChooseRep [ (TypeHtml,
+    foldM f a $ toChunks $ cs t
-              \(TemplateFile fp h) -> do
-                    contents <- readFile fp
-                    let t = newSTMP contents
-                    return $ cs $ toString $ setAttribute "o" h t
-             )
-           , (TypeJson, \(TemplateFile _ ho) ->
-                            return $ cs $ unJsonDoc $ cs ho)
-           ]

Yesod/Yesod.hs

@@ -14,10 +14,8 @@ import Yesod.Response
 import Yesod.Request
 import Yesod.Definitions
 import Yesod.Handler
-import Yesod.Template (TemplateGroup)
 
 import Data.Maybe (fromMaybe)
-import Text.StringTemplate
 import Web.Mime
 import Web.Encodings (parseHttpAccept)
 
@@ -46,10 +44,6 @@ class Yesod a where
     errorHandler :: ErrorResponse -> Handler a ChooseRep
     errorHandler = defaultErrorHandler
 
-    -- | The template directory. Blank means no templates.
-    templateDir :: a -> FilePath
-    templateDir _ = ""
-
     -- | Applies some form of layout to <title> and <body> contents of a page.
     applyLayout :: a
                 -> String -- ^ title
@@ -109,7 +103,7 @@ defaultErrorHandler (InternalError e) =
 toHackApp :: Yesod y => y -> IO Hack.Application
 toHackApp a = do
     key <- encryptKey a
-    app' <- toHackApp' a
+    let app' = toHackApp' a
     let mins = clientSessionDuration a
     return $ gzip
            $ cleanPath
@@ -118,22 +112,14 @@ toHackApp a = do
            $ clientsession encryptedCookies key mins
            $ app'
 
-toHackApp' :: Yesod y => y -> IO Hack.Application
+toHackApp' :: Yesod y => y -> Hack.Env -> IO Hack.Response
-toHackApp' y = do
+toHackApp' y env = do
-    let td = templateDir y
-    tg <- if null td
-            then return nullGroup
-            else directoryGroupRecursiveLazy td
-    return $ toHackApp'' y tg
-
-toHackApp'' :: Yesod y => y -> TemplateGroup -> Hack.Env -> IO Hack.Response
-toHackApp'' y tg env = do
     let (Right resource) = splitPath $ Hack.pathInfo env
         types = httpAccept env
         verb = cs $ Hack.requestMethod env
         handler = handlers resource verb
         rr = cs env
-    res <- runHandler handler errorHandler rr y tg types
+    res <- runHandler handler errorHandler rr y types
     responseToHackResponse res
 
 httpAccept :: Hack.Env -> [ContentType]