diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 5d863972..ade2f79a 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -56,29 +56,29 @@ import Control.Monad.IO.Control (MonadControlIO) -- | 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 m monad a } -- FIXME remove s +newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a } deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO) -instance MonadTrans (GGWidget s m) where +instance MonadTrans (GGWidget m) where lift = GWidget . lift -type GWidget s m = GGWidget s m (GHandler s m) +type GWidget s m = GGWidget m (GHandler s m) type GWInner master = RWST () (GWData (Route master)) Int -instance (Monad monad, a ~ ()) => Monoid (GGWidget sub master monad a) where +instance (Monad monad, a ~ ()) => Monoid (GGWidget master monad a) where mempty = return () mappend x y = x >> y -instance (Monad monad, a ~ ()) => HamletValue (GGWidget s m monad a) where - newtype HamletMonad (GGWidget s m monad a) b = - GWidget' { runGWidget' :: GGWidget s m monad b } - type HamletUrl (GGWidget s m monad a) = Route m +instance (Monad monad, a ~ ()) => HamletValue (GGWidget m monad a) where + newtype HamletMonad (GGWidget m monad a) b = + GWidget' { runGWidget' :: GGWidget m monad b } + type HamletUrl (GGWidget m monad a) = Route m toHamletValue = runGWidget' htmlToHamletMonad = GWidget' . addHtml urlToHamletMonad url params = GWidget' $ addHamlet $ \r -> preEscapedText (r url params) fromHamletValue = GWidget' -instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where +instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget m monad a)) where return = GWidget' . return x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y @@ -94,79 +94,79 @@ addSubWidget sub (GWidget w) = do -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. -setTitle :: Monad m => Html -> GGWidget sub master m () +setTitle :: Monad m => Html -> GGWidget master m () 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 :: Monad m => Hamlet (Route master) -> GGWidget master m () 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 :: Monad m => Html -> GGWidget master m () addHtmlHead = addHamletHead . const -- | Add a 'Hamlet' to the body tag. -addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m () +addHamlet :: Monad m => Hamlet (Route master) -> GGWidget master m () 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 :: Monad m => Html -> GGWidget master m () addHtml = addHamlet . const -- | Add another widget. This is defined as 'id', by can help with types, and -- makes widget blocks look more consistent. -addWidget :: Monad mo => GGWidget s m mo () -> GGWidget s m mo () +addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo () addWidget = id -- | Add some raw CSS to the style tag. -addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m () +addCassius :: Monad m => Cassius (Route master) -> GGWidget master m () 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 :: Monad m => Route master -> GGWidget master m () addStylesheet = flip addStylesheetAttrs [] -- | Link to the specified local stylesheet. -addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub master m () +addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m () addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty -- | Link to the specified remote stylesheet. -addStylesheetRemote :: Monad m => Text -> GGWidget sub master m () +addStylesheetRemote :: Monad m => Text -> GGWidget master m () addStylesheetRemote = flip addStylesheetRemoteAttrs [] -- | Link to the specified remote stylesheet. -addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget sub master m () +addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m () addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty -addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget sub master m () +addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget master m () addStylesheetEither = either addStylesheet addStylesheetRemote -addScriptEither :: Monad m => Either (Route master) Text -> GGWidget sub master m () +addScriptEither :: Monad m => Either (Route master) Text -> GGWidget master m () addScriptEither = either addScript addScriptRemote -- | Link to the specified local script. -addScript :: Monad m => Route master -> GGWidget sub master m () +addScript :: Monad m => Route master -> GGWidget master m () addScript = flip addScriptAttrs [] -- | Link to the specified local script. -addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget sub master m () +addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m () addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty -- | Link to the specified remote script. -addScriptRemote :: Monad m => Text -> GGWidget sub master m () +addScriptRemote :: Monad m => Text -> GGWidget master m () addScriptRemote = flip addScriptRemoteAttrs [] -- | Link to the specified remote script. -addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget sub master m () +addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m () addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty -- | Include raw Javascript in the page's script tag. -addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m () +addJulius :: Monad m => Julius (Route master) -> GGWidget master m () 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 :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m)) extractBody (GWidget w) = GWidget $ mapRWST (liftM go) w where