Basic implementation of template groups

Data/Object/Html.hs

@@ -186,7 +186,7 @@ instance ToSElem HtmlObject where
 #if TEST
 caseHtmlToText :: Assertion
 caseHtmlToText = do
-    let actual = Tag "div" [("id", "foo"), ("class", "bar")]
+    let actual = Tag "div" [("id", "foo"), ("class", "bar")] $ HtmlList
             [ Html $ cs "<br>Some HTML<br>"
             , Text $ cs "<'this should be escaped'>"
             , EmptyTag "img" [("src", "baz&")]

TODO

@@ -1,6 +1,4 @@
-Cleanup Data.Object.Translate
+Some form of i18n.
 Cleanup Parameter stuff. Own module? Interface with formlets?
 Authentication via e-mail address built in. (eaut.org)
 OpenID 2 stuff (for direct Google login).
-Native support for HStringTemplate groups.
-Use Text for HStringTemplate throughout

Yesod.hs

@@ -21,7 +21,7 @@ module Yesod
     , module Yesod.Resource
     , module Data.Object.Html
     , module Yesod.Rep
-    , module Yesod.Templates
+    , module Yesod.Template
     , module Data.Convertible.Text
     , Application
     ) where
@@ -34,6 +34,6 @@ import Yesod.Handler
 import Yesod.Resource
 import Hack (Application)
 import Yesod.Rep
-import Yesod.Templates
+import Yesod.Template
 import Data.Object.Html
 import Data.Convertible.Text

Yesod/Handler.hs

@@ -38,6 +38,7 @@ module Yesod.Handler
 import Yesod.Request
 import Yesod.Response
 import Yesod.Rep
+import Yesod.Template
 
 import Control.Exception hiding (Handler)
 import Control.Applicative
@@ -49,11 +50,10 @@ import Control.Monad (liftM, ap)
 import System.IO
 import Data.Object.Html
 
---import Data.Typeable
-
 ------ Handler monad
 newtype Handler yesod a = Handler {
-    unHandler :: (RawRequest, yesod) -> IO ([Header], HandlerContents a)
+    unHandler :: (RawRequest, yesod, TemplateGroup)
+              -> IO ([Header], HandlerContents a)
 }
 data HandlerContents a =
     forall e. Exception e => HCError e
@@ -81,22 +81,26 @@ instance MonadIO (Handler yesod) where
 instance Exception e => Failure e (Handler yesod) where
     failure e = Handler $ \_ -> return ([], HCError e)
 instance MonadRequestReader (Handler yesod) where
-    askRawRequest = Handler $ \(rr, _) -> return ([], HCContent rr)
+    askRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr)
     invalidParam _pt pn pe = invalidArgs [(pn, pe)]
     authRequired = permissionDenied
 
 getYesod :: Handler yesod yesod
-getYesod = Handler $ \(_, yesod) -> return ([], HCContent yesod)
+getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod)
+
+instance HasTemplateGroup (Handler yesod) where
+    getTemplateGroup = Handler $ \(_, _, tg) -> return ([], HCContent tg)
 
 runHandler :: Handler yesod RepChooser
            -> (ErrorResult -> Handler yesod RepChooser)
            -> RawRequest
            -> yesod
+           -> TemplateGroup
            -> [ContentType]
            -> IO Response
-runHandler (Handler handler) eh rr y cts = do
+runHandler (Handler handler) eh rr y tg cts = do
     (headers, contents) <- Control.Exception.catch
-        (handler (rr, y))
+        (handler (rr, y, tg))
         (\e -> return ([], HCError (e :: Control.Exception.SomeException)))
     let contents' =
             case contents of
@@ -105,7 +109,7 @@ runHandler (Handler handler) eh rr y cts = do
                 HCContent a -> Right a
     case contents' of
         Left e -> do
-            Response _ hs ct c <- runHandler (eh e) specialEh rr y cts
+            Response _ hs ct c <- runHandler (eh e) specialEh rr y tg cts
             let hs' = headers ++ hs ++ getHeaders e
             return $ Response (getStatus e) hs' ct c
         Right a -> do

Yesod/Rep.hs

@@ -47,7 +47,6 @@ module Yesod.Rep
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy as BL
 import Data.Text.Lazy (Text)
-import qualified Data.Text.Lazy as TL
 import Data.Maybe (mapMaybe)
 import Data.Function (on)
 
@@ -162,15 +161,24 @@ instance HasReps Plain where
 plain :: ConvertSuccess x Text => x -> Plain
 plain = Plain . cs
 
-data Template = Template (StringTemplate Text) HtmlObject
+data Template = Template (StringTemplate Text)
+                         String
+                         HtmlObject
+                         (IO [(String, HtmlObject)])
 instance HasReps Template where
     reps = [ (TypeHtml,
-              \(Template t h) ->
-                return $ cs $ render $ setAttribute "o" h t)
-           , (TypeJson, \(Template _ ho) ->
+              \(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)
            ]
 
+-- FIXME
 data TemplateFile = TemplateFile FilePath HtmlObject
 instance HasReps TemplateFile where
     reps = [ (TypeHtml,
@@ -231,7 +239,7 @@ caseChooseRepTemplate = do
         ho = toHtmlObject [ ("foo", toHtmlObject "<fooval>")
                           , ("bar", toHtmlObject ["bar1", "bar2"])
                           ]
-        hasreps = Template temp ho
+        hasreps = Template temp "o" ho $ return []
         res1 = cs "foo:&lt;fooval&gt;, bar:bar1bar2"
         res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++
                     "\"foo\":\"&lt;fooval&gt;\"}"

Yesod/Resource.hs

@@ -43,7 +43,7 @@ import Language.Haskell.TH.Ppr
 import System.IO
 -}
 
-import Data.Typeable (Typeable)
+import Data.Typeable
 import Control.Exception (Exception)
 import Data.Attempt -- for failure stuff
 import Data.Object.Text
@@ -62,7 +62,6 @@ import Test.Framework.Providers.QuickCheck (testProperty)
 import Test.HUnit hiding (Test)
 import Test.QuickCheck
 import Control.Monad (when)
-import Data.Typeable
 #endif
 
 resources :: QuasiQuoter

Yesod/Template.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Yesod.Template
+    ( HasTemplateGroup (..)
+    , template
+    , NoSuchTemplate
+    , TemplateGroup
+    ) where
+
+import Data.Object.Html
+import Data.Typeable (Typeable)
+import Control.Exception (Exception)
+import Control.Failure
+import Yesod.Rep
+import Data.Object.Text (Text)
+import Text.StringTemplate
+
+type TemplateGroup = STGroup Text
+
+class HasTemplateGroup a where
+    getTemplateGroup :: a TemplateGroup
+
+-- FIXME better home
+template :: (MonadFailure NoSuchTemplate t, HasTemplateGroup t)
+         => String -- ^ template name
+         -> String -- ^ object name
+         -> HtmlObject -- ^ object
+         -> IO [(String, HtmlObject)] -- ^ template attributes
+         -> t Template
+template tn on o attrs = do
+    tg <- getTemplateGroup
+    t <- case getStringTemplate tn tg of
+            Nothing -> failure $ NoSuchTemplate tn
+            Just x -> return x
+    return $ Template t on o attrs
+newtype NoSuchTemplate = NoSuchTemplate String
+    deriving (Show, Typeable)
+instance Exception NoSuchTemplate

Yesod/Yesod.hs

@@ -16,6 +16,7 @@ import Yesod.Utils
 
 import Data.Maybe (fromMaybe)
 import Data.Convertible.Text
+import Text.StringTemplate
 
 import qualified Hack
 import Hack.Middleware.CleanPath
@@ -41,6 +42,10 @@ class Yesod a where
     errorHandler :: ErrorResult -> Handler a RepChooser
     errorHandler = defaultErrorHandler
 
+    -- | The template directory. Blank means no templates.
+    templateDir :: a -> FilePath
+    templateDir _ = ""
+
 class Yesod a => YesodApproot a where
     -- | An absolute URL to the root of the application.
     approot :: a -> Approot
@@ -80,7 +85,12 @@ toHackApp' y env = do
         verb = cs $ Hack.requestMethod env
         handler = handlers resource verb
         rr = cs env
-    res <- runHandler handler errorHandler rr y types
+    -- FIXME don't do the templateDir thing for each request
+    let td = templateDir y
+    tg <- if null td
+            then return nullGroup
+            else directoryGroupRecursiveLazy td
+    res <- runHandler handler errorHandler rr y tg types
     let langs = ["en"] -- FIXME
     responseToHackResponse langs res
 

examples/hellotemplate.lhs

@@ -4,7 +4,7 @@
 import Yesod
 import Hack.Handler.SimpleServer
 
-data HelloWorld = HelloWorld TemplateGroup
+data HelloWorld = HelloWorld
 instance Yesod HelloWorld where
     handlers = [$resources|
 /:
@@ -12,9 +12,7 @@ instance Yesod HelloWorld where
 /groups:
     Get: helloGroup
 |]
-
-instance YesodTemplates HelloWorld where
-    templates (HelloWorld g) = g
+    templateDir _ = "examples"
 
 helloWorld :: Handler HelloWorld TemplateFile
 helloWorld = return $ TemplateFile "examples/template.html" $ cs
@@ -22,11 +20,10 @@ helloWorld = return $ TemplateFile "examples/template.html" $ cs
                 , ("content", "Hey look!! I'm <auto escaped>!")
                 ]
 
-helloGroup = template "real-template" $ cs "foo"
+helloGroup = template "real-template" "foo" (cs "bar") $ return []
 
 main :: IO ()
 main = do
     putStrLn "Running..."
-    stg <- loadTemplates "examples"
-    run 3000 (toHackApp $ HelloWorld stg)
+    run 3000 $ toHackApp HelloWorld
 \end{code}

examples/real-template.st

@@ -1 +1,2 @@
 This is a more realistic template.
+foo: $foo$

test/quasi-resource.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 
 import Yesod
+import Text.StringTemplate (nullGroup)
 
 data MyYesod = MyYesod
 
@@ -54,7 +55,7 @@ ph h = do
         rr = error "No raw request"
         y = MyYesod
         cts = [TypeHtml]
-    res <- runHandler h eh rr y cts
+    res <- runHandler h eh rr y nullGroup cts
     print res
 
 main :: IO ()

yesod.cabal

@@ -51,7 +51,8 @@ library
                      HStringTemplate >= 0.6.2 && < 0.7,
                      data-object-json >= 0.0.0 && < 0.1,
                      attempt >= 0.2.1 && < 0.3,
-                     template-haskell
+                     template-haskell,
+                     failure >= 0.0.0 && < 0.1
     exposed-modules: Yesod
                      Yesod.Constants
                      Yesod.Rep
@@ -62,7 +63,7 @@ library
                      Yesod.Handler
                      Yesod.Resource
                      Yesod.Yesod
-                     Yesod.Templates
+                     Yesod.Template
                      Data.Object.Html
                      Hack.Middleware.MethodOverride
                      Hack.Middleware.ClientSession