Recent hamlet changes

Yesod/Hamlet.hs

@@ -20,9 +20,10 @@ import Yesod.Response
 import Yesod.Handler
 import Data.Convertible.Text
 import Data.Object
+import Control.Arrow ((***))
 
 data PageContent url = PageContent
-    { pageTitle :: IO HtmlContent
+    { pageTitle :: HtmlContent
     , pageHead :: Hamlet url IO ()
     , pageBody :: Hamlet url IO ()
     }
@@ -54,21 +55,18 @@ instance Monad m
                 %ul
                     $forall s' s
                         %li ^s^|]
-        s' _ = return $ fromList $ map cs s
+        s' _ = map cs s
     convertSuccess (Mapping m) = template () where
         template :: Monad m => () -> Hamlet url m ()
         template = [$hamlet|
                 %dl
                     $forall pairs pair
-                        %dt $pair.key$
-                        %dd ^pair.val^|]
-        pairs _ = return $ fromList $ map go m
-        go (k, v) = Pair (return $ cs k) $ cs v
+                        %dt $pair.fst$
+                        %dd ^pair.snd^|]
+        pairs _ = map (cs *** cs) m
 instance ConvertSuccess String HtmlContent where
     convertSuccess = Unencoded . cs
 
-data Pair url m = Pair { key :: m HtmlContent, val :: Hamlet url m () }
-
 type HtmlObject = Object String HtmlContent
 
 instance ConvertSuccess (Object String String) HtmlObject where

Yesod/Helpers/Auth.hs

@@ -113,9 +113,9 @@ authOpenidForm = do
     simpleApplyLayout "Log in via OpenID" html
   where
     urlForward _ = error "FIXME urlForward"
-    hasMessage = return . not . null
-    message [] = return $ Encoded $ cs ""
-    message (m:_) = return $ Unencoded $ cs m
+    hasMessage = not . null
+    message [] = cs ""
+    message (m:_) = cs m
     template = [$hamlet|
 $if hasMessage
     %p.message $message$

Yesod/Yesod.hs

@@ -17,7 +17,7 @@ import Yesod.Handler hiding (badMethod)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as B8
 import Data.Convertible.Text
-import Text.Hamlet.Monad (fromList)
+import Control.Arrow ((***))
 
 import Data.Maybe (fromMaybe)
 import Web.Mime
@@ -83,7 +83,7 @@ simpleApplyLayout :: Yesod y
                   -> Handler y ChooseRep
 simpleApplyLayout t b = do
     let pc = PageContent
-                { pageTitle = return $ Unencoded $ cs t
+                { pageTitle = cs t
                 , pageHead = return ()
                 , pageBody = b
                 }
@@ -105,7 +105,7 @@ defaultErrorHandler NotFound = do
 %p $helper$
 |] r
   where
-    helper = return . Unencoded . cs . W.pathInfo
+    helper = Unencoded . cs . W.pathInfo
 defaultErrorHandler PermissionDenied =
     simpleApplyLayout "Permission Denied" $ [$hamlet|
 %h1 Permission denied|] ()
@@ -114,30 +114,21 @@ defaultErrorHandler (InvalidArgs ia) =
 %h1 Invalid Arguments
 %dl
     $forall ias pair
-        %dt $pair.key$
-        %dd $pair.val$
+        %dt $pair.fst$
+        %dd $pair.snd$
 |] ()
   where
-    ias _ = return $ fromList $ map go ia
-    go (k, v) = Pair (return $ Unencoded $ cs k)
-                     (return $ Unencoded $ cs v)
+    ias _ = map (cs *** cs) ia
 defaultErrorHandler (InternalError e) =
     simpleApplyLayout "Internal Server Error" $ [$hamlet|
 %h1 Internal Server Error
-%p $message$
+%p $cs$
 |] e
-  where
-    message :: String -> IO HtmlContent
-    message = return . Unencoded . cs
 defaultErrorHandler (BadMethod m) =
     simpleApplyLayout "Bad Method" $ [$hamlet|
 %h1 Method Not Supported
-%p Method "$m'$" not supported
-|] ()
-  where
-    m' _ = return $ Unencoded $ cs m
-
-data Pair m k v = Pair { key :: m k, val :: m v }
+%p Method "$cs$" not supported
+|] m
 
 toWaiApp :: Yesod y => y -> IO W.Application
 toWaiApp a = do

examples/hamlet.hs

@@ -15,21 +15,18 @@ mkYesod "Ham" [$parseRoutes|
 instance Yesod Ham where
     approot _ = "http://localhost:3000"
 
-data NextLink m = NextLink { nextLink :: m HamRoutes }
+data NextLink = NextLink { nextLink :: HamRoutes }
 
-nl :: Monad m => HamRoutes -> NextLink m
-nl = NextLink . return
-
-template :: Monad m => NextLink m -> Hamlet HamRoutes m ()
+template :: Monad m => NextLink -> Hamlet HamRoutes m ()
 template = [$hamlet|
 %a!href=@nextLink@ Next page
 |]
 
 getHomepage :: Handler Ham RepHtml
-getHomepage = hamletToRepHtml $ template $ nl $ Another 1
+getHomepage = hamletToRepHtml $ template $ NextLink $ Another 1
 
 getAnother :: Integer -> Handler Ham RepHtml
-getAnother i = hamletToRepHtml $ template $ nl next
+getAnother i = hamletToRepHtml $ template $ NextLink next
   where
     next = case i of
                 5 -> Homepage

examples/pretty-yaml.hs

@@ -36,13 +36,13 @@ template = [$hamlet|
 |]
 
 data TempArgs url m = TempArgs
-    { hasYaml :: m Bool
+    { hasYaml :: Bool
     , yaml :: Hamlet url m ()
     }
 
 getHomepage :: Handler PY RepHtml
 getHomepage = hamletToRepHtml
-            $ template $ TempArgs (return False) (return ())
+            $ template $ TempArgs False (return ())
 
 --FIXMEpostHomepage :: Handler PY RepHtmlJson
 postHomepage :: Handler PY RepHtml
@@ -53,13 +53,13 @@ postHomepage = do
             Nothing -> invalidArgs [("yaml", "Missing input")]
             Just x -> return x
     so <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi
-    {-
+    {- FIXME
     let ho' = fmap Text to
     templateHtmlJson "pretty-yaml" ho' $ \ho ->
         return . setHtmlAttrib "yaml" (Scalar $ cs ho :: HtmlObject)
     -}
     let ho = cs (so :: StringObject) :: HtmlObject
-    hamletToRepHtml $ template $ TempArgs (return True) (cs ho)
+    hamletToRepHtml $ template $ TempArgs True (cs ho)
 
 main :: IO ()
 main = do