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

addJuliusBody

Browse Source
This commit is contained in:
Michael Snoyman 2011-04-01 14:24:21 +03:00
parent b1ecaeee08
commit 2e7e24f2a2
3 changed files with 55 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
Test/Widget.hs Normal file
View File

@ -0,0 +1,45 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
module Test.Widget (widgetTest) where
import Yesod.Core
import Yesod.Content
import Yesod.Dispatch
import Yesod.Widget
import Text.Julius
import Test.Framework (defaultMain, testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test)
import Network.Wai
import Network.Wai.Test
import qualified Data.ByteString.Lazy.Char8 as L8
data Y = Y
mkYesod "Y" [$parseRoutes|
/ RootR GET
|]
instance Yesod Y where
approot _ = "http://test"
getRootR = defaultLayout $ addJuliusBody [$julius|<not escaped>|]
widgetTest :: Test
widgetTest = testGroup "Test.Exceptions"
[ testCase "addJuliusBody" case_addJuliusBody
]
runner f = toWaiApp Y >>= runSession f
defaultRequest = Request
{ pathInfo = []
, requestHeaders = []
, queryString = []
, requestMethod = "GET"
}
case_addJuliusBody = runner $ do
res <- request defaultRequest
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script><not escaped></script></body></html>" res

9
Yesod/Widget.hs
View File

@ -27,6 +27,7 @@ module Yesod.Widget
, addStylesheetEither , addStylesheetEither
-- ** Javascript -- ** Javascript
, addJulius , addJulius
, addJuliusBody
, addScript , addScript
, addScriptAttrs , addScriptAttrs
, addScriptRemote , addScriptRemote
@ -38,7 +39,8 @@ module Yesod.Widget
import Data.Monoid import Data.Monoid
import Control.Monad.Trans.RWS import Control.Monad.Trans.RWS
import Text.Blaze (preEscapedText) import Text.Blaze (preEscapedText, preEscapedLazyText)
import qualified Text.Blaze.Html5 as H
import Text.Hamlet import Text.Hamlet
import Text.Cassius import Text.Cassius
import Text.Julius import Text.Julius
@ -164,6 +166,11 @@ addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Scr
addJulius :: Monad m => Julius (Route master) -> GGWidget master m () addJulius :: Monad m => Julius (Route master) -> GGWidget master m ()
addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
-- | Add a new script tag to the body with the contents of this 'Julius'
-- template.
addJuliusBody :: Monad m => Julius (Route master) -> GGWidget master m ()
addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJulius r j
-- | Pull out the HTML tag contents and return it. Useful for performing some -- | Pull out the HTML tag contents and return it. Useful for performing some
-- manipulations. It can be easier to use this sometimes than 'wrapWidget'. -- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m)) extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m))

2
runtests.hs
View File

@ -1,9 +1,11 @@
import Test.Framework (defaultMain) import Test.Framework (defaultMain)
import Test.CleanPath import Test.CleanPath
import Test.Exceptions import Test.Exceptions
import Test.Widget
main :: IO () main :: IO ()
main = defaultMain main = defaultMain
[ cleanPathTest [ cleanPathTest
, exceptionsTest , exceptionsTest
, widgetTest
] ]