diff --git a/Test/Media.hs b/Test/Media.hs
new file mode 100644
index 00000000..75d8c447
--- /dev/null
+++ b/Test/Media.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Test.Media (mediaTest) where
+
+import Yesod.Core hiding (Request)
+
+import Test.Framework (defaultMain, testGroup, Test)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+import Network.Wai
+import Network.Wai.Test
+import Network.HTTP.Types (status200, decodePathSegments)
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.Text as TS
+import Text.Lucius
+
+data Y = Y
+mkYesod "Y" [$parseRoutes|
+/ RootR GET
+/static StaticR GET
+|]
+
+instance Yesod Y where
+ approot _ = ""
+ addStaticContent _ _ content = do
+ tm <- getRouteToMaster
+ route <- getCurrentRoute
+ case fmap tm route of
+ Just StaticR -> return $ Just $ Left $
+ if content == "foo2{bar:baz}"
+ then "screen.css"
+ else "all.css"
+ _ -> return Nothing
+
+getRootR = defaultLayout $ do
+ addCassius [$lucius|foo1{bar:baz}|]
+ addCassiusMedia "screen" [$lucius|foo2{bar:baz}|]
+ addCassius [$lucius|foo3{bar:baz}|]
+getStaticR = getRootR
+
+runner f = toWaiApp Y >>= runSession f
+defaultRequest = Request
+ { pathInfo = []
+ , requestHeaders = []
+ , queryString = []
+ , requestMethod = "GET"
+ }
+
+caseMedia = runner $ do
+ res <- request defaultRequest
+ assertStatus 200 res
+ flip assertBody res "\n"
+
+caseMediaLink = runner $ do
+ res <- request defaultRequest { pathInfo = ["static"] }
+ assertStatus 200 res
+ flip assertBody res "\n"
+
+mediaTest = testGroup "Test.Media"
+ [ testCase "media" caseMedia
+ , testCase "media link" caseMediaLink
+ ]
diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs
index 3778143d..5fba8c79 100644
--- a/Yesod/Internal.hs
+++ b/Yesod/Internal.hs
@@ -43,6 +43,7 @@ import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types as A
import Data.CaseInsensitive (CI)
import Data.String (IsString)
+import qualified Data.Map as Map
#if GHC7
#define HAMLET hamlet
@@ -111,7 +112,7 @@ data GWData a = GWData
!(Last Title)
!(UniqueList (Script a))
!(UniqueList (Stylesheet a))
- !(Maybe (Cassius a))
+ !(Map.Map (Maybe Text) (Cassius a)) -- media type
!(Maybe (Julius a))
!(Head a)
instance Monoid (GWData a) where
@@ -122,6 +123,6 @@ instance Monoid (GWData a) where
(a2 `mappend` b2)
(a3 `mappend` b3)
(a4 `mappend` b4)
- (a5 `mappend` b5)
+ (Map.unionWith mappend a5 b5)
(a6 `mappend` b6)
(a7 `mappend` b7)
diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs
index 1c1b2ac0..298f25d2 100644
--- a/Yesod/Internal/Core.hs
+++ b/Yesod/Internal/Core.hs
@@ -478,13 +478,14 @@ widgetToPageContent (GWidget w) = do
Nothing -> Nothing
Just (Left s) -> Just s
Just (Right (u, p)) -> Just $ render u p
- cssLoc <-
- case style of
- Nothing -> return Nothing
- Just s -> do
- x <- addStaticContent "css" "text/css; charset=utf-8"
- $ encodeUtf8 $ renderCassius render s
- return $ renderLoc x
+ css <- flip mapM (Map.toList style) $ \(mmedia, content) -> do
+ let rendered = renderCassius render content
+ x <- addStaticContent "css" "text/css; charset=utf-8"
+ $ encodeUtf8 rendered
+ return (mmedia,
+ case x of
+ Nothing -> Left $ preEscapedLazyText rendered
+ Just y -> Right $ either id (uncurry render) y)
jsLoc <-
case jscript of
Nothing -> return Nothing
@@ -504,6 +505,10 @@ widgetToPageContent (GWidget w) = do
: ("href", renderLoc' render' loc)
: attrs
)
+ let left (Left x) = Just x
+ left _ = Nothing
+ right (Right x) = Just x
+ right _ = Nothing
let head'' =
#if GHC7
[hamlet|
@@ -514,11 +519,17 @@ $forall s <- scripts
^{mkScriptTag s}
$forall s <- stylesheets
^{mkLinkTag s}
-$maybe s <- style
- $maybe s <- cssLoc
- ^{celper s}
+$forall s <- css
+ $maybe t <- right $ snd s
+ $maybe media <- fst s
+ #{content}
+ $nothing
+