addCassiusMedia

2011-04-08 11:53:54 +03:00 · 2011-04-08 11:53:54 +03:00 · e114a057fb
commit e114a057fb
parent b778372e2f
6 changed files with 102 additions and 16 deletions
--- a/Test/Media.hs
+++ 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 "<!DOCTYPE html>\n<html><head><title></title><style>foo1{bar:baz}foo3{bar:baz}</style><style media=\"screen\">foo2{bar:baz}</style></head><body></body></html>"
+
+caseMediaLink = runner $ do
+    res <- request defaultRequest { pathInfo = ["static"] }
+    assertStatus 200 res
+    flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><link rel=\"stylesheet\" href=\"all.css\"><link rel=\"stylesheet\" media=\"screen\" href=\"screen.css\"></head><body></body></html>"
+
+mediaTest = testGroup "Test.Media"
+    [ testCase "media" caseMedia
+    , testCase "media link" caseMediaLink
+    ]
--- 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)
--- 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
-        <link rel=stylesheet href=#{s}
-    $nothing
-        <style>^{celper s}
+$forall s <- css
+    $maybe t <- right $ snd s
+        $maybe media <- fst s
+            <link rel=stylesheet media=#{media} href=#{t}
+        $nothing
+            <link rel=stylesheet href=#{t}
+    $maybe content <- left $ snd s
+        $maybe media <- fst s
+            <style media=#{media}>#{content}
+        $nothing
+            <style>#{content}
 $maybe j <- jscript
    $maybe s <- jsLoc
        <script src="#{s}">
--- a/Yesod/Widget.hs
+++ b/Yesod/Widget.hs
@ -20,6 +20,7 @@ module Yesod.Widget
    , addSubWidget
      -- ** CSS
    , addCassius
+    , addCassiusMedia
    , addStylesheet
    , addStylesheetAttrs
    , addStylesheetRemote
@ -52,6 +53,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
 import Yesod.Internal
 import Control.Monad (liftM)
 import Data.Text (Text)
+import qualified Data.Map as Map

 import Control.Monad.IO.Control (MonadControlIO)

@ -120,9 +122,13 @@ addHtml = addHamlet . const
 addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo ()
 addWidget = id

-- | Add some raw CSS to the style tag.
+-- | Add some raw CSS to the style tag. Applies to all media types.
 addCassius :: Monad m => Cassius (Route master) -> GGWidget master m ()
-addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Just x) mempty mempty
+addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing x) mempty mempty
+
+-- | Add some raw CSS to the style tag, for a specific media type.
+addCassiusMedia :: Monad m => Text -> Cassius (Route master) -> GGWidget master m ()
+addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) x) mempty mempty

 -- | Link to the specified local stylesheet.
 addStylesheet :: Monad m => Route master -> GGWidget master m ()
--- a/runtests.hs
+++ b/runtests.hs
@ -2,10 +2,12 @@ import Test.Framework (defaultMain)
 import Test.CleanPath
 import Test.Exceptions
 import Test.Widget
+import Test.Media

 main :: IO ()
 main = defaultMain
    [ cleanPathTest
    , exceptionsTest
    , widgetTest
+    , mediaTest
    ]
--- a/yesod-core.cabal
+++ b/yesod-core.cabal
@ -62,6 +62,8 @@ library
                     Yesod.Internal.Dispatch
                     Paths_yesod_core
    ghc-options:     -Wall
+    if flag(test)
+        Buildable: False

 executable             runtests
    if flag(ghc7)