diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 7b6b034b..1e606cbc 100644 --- a/Yesod/Hamlet.hs +++ b/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 diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index b80907f7..06944666 100644 --- a/Yesod/Helpers/Auth.hs +++ b/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$ diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 612e3fb6..87369a16 100644 --- a/Yesod/Yesod.hs +++ b/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 diff --git a/examples/hamlet.hs b/examples/hamlet.hs index 268b3909..447bf5dd 100644 --- a/examples/hamlet.hs +++ b/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 diff --git a/examples/pretty-yaml.hs b/examples/pretty-yaml.hs index c6080b84..1054936b 100644 --- a/examples/pretty-yaml.hs +++ b/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