yesod-core 0.7.0.1 → 0.7.0.2
raw patch · 5 files changed
+55/−71 lines, 5 files
Files
- Yesod/Core.hs +2/−13
- Yesod/Internal.hs +24/−1
- Yesod/Widget.hs +26/−56
- runtests.hs +2/−0
- yesod-core.cabal +1/−1
Yesod/Core.hs view
@@ -41,8 +41,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Monoid-import Control.Monad.Trans.Writer-import Control.Monad.Trans.State hiding (get, put)+import Control.Monad.Trans.RWS import Text.Hamlet import Text.Cassius import Text.Julius@@ -393,17 +392,7 @@ => GWidget sub master () -> GHandler sub master (PageContent (Route master)) widgetToPageContent (GWidget w) = do- w' <- flip evalStateT 0- $ runWriterT $ runWriterT $ runWriterT $ runWriterT- $ runWriterT $ runWriterT $ runWriterT w- let ((((((((),- Body body),- Last mTitle),- scripts'),- stylesheets'),- style),- jscript),- Head head') = w'+ ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0 let title = maybe mempty unTitle mTitle let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' let stylesheets = map (locationToHamlet . unStylesheet)
Yesod/Internal.hs view
@@ -12,6 +12,7 @@ -- * Cookie names , langKey -- * Widgets+ , GWData (..) , Location (..) , UniqueList (..) , Script (..)@@ -32,7 +33,9 @@ ) where import Text.Hamlet (Hamlet, hamlet, Html)-import Data.Monoid (Monoid (..))+import Text.Cassius (Cassius)+import Text.Julius (Julius)+import Data.Monoid (Monoid (..), Last) import Data.List (nub) import Data.ByteString (ByteString)@@ -120,3 +123,23 @@ sessionName :: ByteString sessionName = "_SESSION"++data GWData a = GWData+ !(Body a)+ !(Last Title)+ !(UniqueList (Script a))+ !(UniqueList (Stylesheet a))+ !(Maybe (Cassius a))+ !(Maybe (Julius a))+ !(Head a)+instance Monoid (GWData a) where+ mempty = GWData mempty mempty mempty mempty mempty mempty mempty+ mappend (GWData a1 a2 a3 a4 a5 a6 a7)+ (GWData b1 b2 b3 b4 b5 b6 b7) = GWData+ (a1 `mappend` b1)+ (a2 `mappend` b2)+ (a3 `mappend` b3)+ (a4 `mappend` b4)+ (a5 `mappend` b5)+ (a6 `mappend` b6)+ (a7 `mappend` b7)
Yesod/Widget.hs view
@@ -33,8 +33,7 @@ ) where import Data.Monoid-import Control.Monad.Trans.Writer-import Control.Monad.Trans.State+import Control.Monad.Trans.RWS import Text.Hamlet import Text.Cassius import Text.Julius@@ -51,24 +50,15 @@ -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of -- dependencies along with a 'StateT' to track unique identifiers.-newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner s m monad a }+newtype GGWidget s m monad a = GWidget { unGWidget :: GWInner m monad a } -- FIXME remove s deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) instance MonadTrans (GGWidget s m) where- lift = GWidget . lift . lift . lift . lift . lift . lift . lift . lift+ lift = GWidget . lift type GWidget s m = GGWidget s m (GHandler s m)-type GWInner sub master monad =- WriterT (Body (Route master)) (- WriterT (Last Title) (- WriterT (UniqueList (Script (Route master))) (- WriterT (UniqueList (Stylesheet (Route master))) (- WriterT (Maybe (Cassius (Route master))) (- WriterT (Maybe (Julius (Route master))) (- WriterT (Head (Route master)) (- StateT Int (- monad- ))))))))+type GWInner master = RWST () (GWData (Route master)) Int+ instance (Monad monad, a ~ ()) => Monoid (GGWidget sub master monad a) where mempty = return () mappend x y = x >> y@@ -87,53 +77,35 @@ x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a-addSubWidget sub w = do master <- lift getYesod- let sr = fromSubRoute sub master- i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get- w' <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i- $ runWriterT $ runWriterT $ runWriterT $ runWriterT- $ runWriterT $ runWriterT $ runWriterT - $ unGWidget w- let ((((((((a,- body),- title),- scripts),- stylesheets),- style),- jscript),- h),- i') = w'- GWidget $ do- tell body- lift $ tell title- lift $ lift $ tell scripts- lift $ lift $ lift $ tell stylesheets- lift $ lift $ lift $ lift $ tell style- lift $ lift $ lift $ lift $ lift $ tell jscript- lift $ lift $ lift $ lift $ lift $ lift $ tell h- lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i'- return a+addSubWidget sub (GWidget w) = do+ master <- lift getYesod+ let sr = fromSubRoute sub master+ s <- GWidget get+ (a, s', w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runRWST w () s+ GWidget $ put s'+ GWidget $ tell w'+ return a -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. setTitle :: Monad m => Html -> GGWidget sub master m ()-setTitle = GWidget . lift . tell . Last . Just . Title+setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty -- | Add a 'Hamlet' to the head tag. addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()-addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head+addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head -- | Add a 'Html' to the head tag. addHtmlHead :: Monad m => Html -> GGWidget sub master m ()-addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const+addHtmlHead = addHamletHead . const -- | Add a 'Hamlet' to the body tag. addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()-addHamlet = GWidget . tell . Body+addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty -- | Add a 'Html' to the body tag. addHtml :: Monad m => Html -> GGWidget sub master m ()-addHtml = GWidget . tell . Body . const+addHtml = addHamlet . const -- | Add another widget. This is defined as 'id', by can help with types, and -- makes widget blocks look more consistent.@@ -142,16 +114,15 @@ -- | Add some raw CSS to the style tag. addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m ()-addCassius = GWidget . lift . lift . lift . lift . tell . Just+addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Just x) mempty mempty -- | Link to the specified local stylesheet. addStylesheet :: Monad m => Route master -> GGWidget sub master m ()-addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local+addStylesheet x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Local x) mempty mempty mempty -- | Link to the specified remote stylesheet. addStylesheetRemote :: Monad m => String -> GGWidget sub master m ()-addStylesheetRemote =- GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote+addStylesheetRemote x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Remote x) mempty mempty mempty addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m () addStylesheetEither = either addStylesheet addStylesheetRemote@@ -161,24 +132,23 @@ -- | Link to the specified local script. addScript :: Monad m => Route master -> GGWidget sub master m ()-addScript = GWidget . lift . lift . tell . toUnique . Script . Local+addScript x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Local x) mempty mempty mempty mempty -- | Link to the specified remote script. addScriptRemote :: Monad m => String -> GGWidget sub master m ()-addScriptRemote =- GWidget . lift . lift . tell . toUnique . Script . Remote+addScriptRemote x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Remote x) mempty mempty mempty mempty -- | Include raw Javascript in the page's script tag. addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m ()-addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just+addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty -- | Pull out the HTML tag contents and return it. Useful for performing some -- manipulations. It can be easier to use this sometimes than 'wrapWidget'. extractBody :: Monad mo => GGWidget s m mo () -> GGWidget s m mo (Hamlet (Route m)) extractBody (GWidget w) =- GWidget $ mapWriterT (liftM go) w+ GWidget $ mapRWST (liftM go) w where- go ((), Body h) = (h, Body mempty)+ go ((), s, GWData (Body h) b c d e f g) = (h, s, GWData (Body mempty) b c d e f g) -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature:
runtests.hs view
@@ -1,7 +1,9 @@ import Test.Framework (defaultMain) import Test.CleanPath+import Test.Exceptions main :: IO () main = defaultMain [ cleanPathTest+ , exceptionsTest ]
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 0.7.0.1+version: 0.7.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>