haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Automatically apply toWidget to ^{} interpolations

Browse Source
This commit is contained in:
Michael Snoyman 2012-04-03 08:07:57 +03:00
parent fc29c153ed
commit 742ffa4d14
2 changed files with 20 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
yesod-core/Yesod/Widget.hs
View File

@ -74,7 +74,7 @@ import Control.Monad (liftM)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Map as Map import qualified Data.Map as Map
import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Quote (QuasiQuoter)
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Exception (throwIO) import Control.Exception (throwIO)
@ -119,7 +119,7 @@ instance render ~ RY master => ToWidget sub master (render -> Css) where
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
instance render ~ RY master => ToWidget sub master (render -> Javascript) where instance render ~ RY master => ToWidget sub master (render -> Javascript) where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
instance ToWidget sub master (GWidget sub master ()) where instance (sub' ~ sub, master' ~ master) => ToWidget sub' master' (GWidget sub master ()) where
toWidget = id toWidget = id
instance ToWidget sub master Html where instance ToWidget sub master Html where
toWidget = toWidget . const toWidget = toWidget . const
@ -277,7 +277,7 @@ rules = do
(Just $ helper [|liftW getUrlRenderParams|]) (Just $ helper [|liftW getUrlRenderParams|])
(Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|]) (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|])
f env f env
return $ NP.HamletRules ah ur $ \_ b -> return b return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: RenderMessage master message ihamletToRepHtml :: RenderMessage master message

17
yesod-core/test/YesodCoreTest/Widget.hs
View File

@ -25,6 +25,7 @@ mkYesod "Y" [parseRoutes|
/foo/*Strings MultiR GET /foo/*Strings MultiR GET
/whamlet WhamletR GET /whamlet WhamletR GET
/towidget TowidgetR GET /towidget TowidgetR GET
/auto AutoR GET
|] |]
instance Yesod Y where instance Yesod Y where
@ -69,11 +70,19 @@ getWhamletR = defaultLayout [whamlet|
where where
embed = [whamlet|<h4>Embed|] embed = [whamlet|<h4>Embed|]
getAutoR :: Handler RepHtml
getAutoR = defaultLayout [whamlet|
^{someHtml}
|]
where
someHtml = [shamlet|somehtml|]
widgetTest :: [Spec] widgetTest :: [Spec]
widgetTest = describe "Test.Widget" widgetTest = describe "Test.Widget"
[ it "addJuliusBody" case_addJuliusBody [ it "addJuliusBody" case_addJuliusBody
, it "whamlet" case_whamlet , it "whamlet" case_whamlet
, it "two letter lang codes" case_two_letter_lang , it "two letter lang codes" case_two_letter_lang
, it "automatically applies toWidget" case_auto
] ]
runner :: Session () -> IO () runner :: Session () -> IO ()
@ -99,3 +108,11 @@ case_two_letter_lang = runner $ do
, requestHeaders = [("Accept-Language", "es-ES")] , requestHeaders = [("Accept-Language", "es-ES")]
} }
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h3>String</h3><h4>Embed</h4></body></html>" res assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h3>String</h3><h4>Embed</h4></body></html>" res
case_auto :: IO ()
case_auto = runner $ do
res <- request defaultRequest
{ pathInfo = ["auto"]
, requestHeaders = [("Accept-Language", "es")]
}
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>somehtml</body></html>" res