{-# LANGUAGE GeneralizedNewtypeDeriving #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE TemplateHaskell #-}{-# LANGUAGE MultiParamTypeClasses #-}{-# LANGUAGE TypeSynonymInstances #-}{-# LANGUAGE UndecidableInstances #-}{-# LANGUAGE CPP #-}-- FIXME Should we remove the older names here (addJulius, etc)?-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier-- generator, allowing you to create truly modular HTML components.moduleYesod.Widget(-- * DatatypeGWidget,PageContent(..)-- * Special Hamlet quasiquoter/TH for Widgets,whamlet,whamletFile,ihamletToRepHtml-- * Convert to Widget,ToWidget(..),ToWidgetHead(..),ToWidgetBody(..)-- * Creating-- ** Head of page,setTitle,setTitleI,addHamletHead,addHtmlHead-- ** Body,addHamlet,addHtml,addWidget,addSubWidget-- ** CSS,addCassius,addCassiusMedia,addLucius,addLuciusMedia,addStylesheet,addStylesheetAttrs,addStylesheetRemote,addStylesheetRemoteAttrs,addStylesheetEither-- ** Javascript,addJulius,addJuliusBody,addScript,addScriptAttrs,addScriptRemote,addScriptRemoteAttrs,addScriptEither-- * Internal,unGWidget,whamletFileWithSettings)whereimportData.MonoidimportqualifiedText.Blaze.Html5asHimportText.HamletimportText.CassiusimportText.JuliusimportYesod.Routes.ClassimportYesod.Handler(GHandler,YesodSubRoute(..),toMasterHandlerMaybe,getYesod,getMessageRender,getUrlRenderParams,MonadLift(..))importYesod.Message(RenderMessage)importYesod.Content(RepHtml(..),toContent)importControl.Applicative(Applicative(..),(<$>))importControl.Monad.IO.Class(MonadIO(liftIO))importYesod.InternalimportControl.Monad(liftM)importData.Text(Text)importqualifiedData.MapasMapimportLanguage.Haskell.TH.Quote(QuasiQuoter)importLanguage.Haskell.TH.Syntax(Q,Exp(InfixE,VarE,LamE,AppE),Pat(VarP),newName)importControl.Monad.Trans.Control(MonadBaseControl(..))importControl.Exception(throwIO)importqualifiedText.HamletasNPimportData.Text.Lazy.Builder(fromLazyText)importText.Blaze.Html(toHtml,preEscapedToMarkup)importqualifiedData.Text.LazyasTLimportControl.Monad.Base(MonadBase(liftBase))importControl.Arrow(first)importControl.Monad.Trans.ResourceimportControl.Monad.LoggerpreEscapedLazyText::TL.Text->HtmlpreEscapedLazyText=preEscapedToMarkup-- | A generic widget, allowing specification of both the subsite and master-- site datatypes. While this is simply a @WriterT@, we define a newtype for-- better error messages.newtypeGWidgetsubmastera=GWidget{unGWidget::GHandlersubmaster(a,GWData(Routemaster))}instance(a~())=>Monoid(GWidgetsubmastera)wheremempty=return()mappendxy=x>>yaddSubWidget::(YesodSubRoutesubmaster)=>sub->GWidgetsubmastera->GWidgetsub'masteraaddSubWidgetsub(GWidgetw)=domaster<-liftgetYesodletsr=fromSubRoutesubmaster(a,w')<-lift$toMasterHandlerMaybesr(constsub)Nothingwtellw'returnaclassToWidgetsubmasterawheretoWidget::a->GWidgetsubmaster()-- FIXME At some point in the future, deprecate all the-- addHamlet/Cassius/Lucius/Julius stuff. For the most part, toWidget* will be-- sufficient. For somethings, like addLuciusMedia, create addCssUrlMedia.typeRYmaster=Routemaster->[(Text,Text)]->Textinstancerender~RYmaster=>ToWidgetsubmaster(render->Html)wheretoWidgetx=tell$GWData(Bodyx)memptymemptymemptymemptymemptymemptyinstancerender~RYmaster=>ToWidgetsubmaster(render->Css)wheretoWidgetx=tell$GWDatamemptymemptymemptymempty(Map.singletonNothing$\r->fromLazyText$renderCss$xr)memptymemptyinstancerender~RYmaster=>ToWidgetsubmaster(render->Javascript)wheretoWidgetx=tell$GWDatamemptymemptymemptymemptymempty(Justx)memptyinstance(sub'~sub,master'~master)=>ToWidgetsub'master'(GWidgetsubmaster())wheretoWidget=idinstanceToWidgetsubmasterHtmlwheretoWidget=toWidget.constclassToWidgetBodysubmasterawheretoWidgetBody::a->GWidgetsubmaster()instancerender~RYmaster=>ToWidgetBodysubmaster(render->Html)wheretoWidgetBody=toWidgetinstancerender~RYmaster=>ToWidgetBodysubmaster(render->Javascript)wheretoWidgetBodyj=toWidget$\r->H.script$preEscapedLazyText$renderJavascriptUrlrjinstanceToWidgetBodysubmasterHtmlwheretoWidgetBody=toWidgetclassToWidgetHeadsubmasterawheretoWidgetHead::a->GWidgetsubmaster()instancerender~RYmaster=>ToWidgetHeadsubmaster(render->Html)wheretoWidgetHead=tell.GWDatamemptymemptymemptymemptymemptymempty.Headinstancerender~RYmaster=>ToWidgetHeadsubmaster(render->Css)wheretoWidgetHead=toWidgetinstancerender~RYmaster=>ToWidgetHeadsubmaster(render->Javascript)wheretoWidgetHeadj=toWidgetHead$\r->H.script$preEscapedLazyText$renderJavascriptUrlrjinstanceToWidgetHeadsubmasterHtmlwheretoWidgetHead=toWidgetHead.const-- | Set the page title. Calling 'setTitle' multiple times overrides previously-- set values.setTitle::Html->GWidgetsubmaster()setTitlex=tell$GWDatamempty(Last$Just$Titlex)memptymemptymemptymemptymempty-- | Set the page title. Calling 'setTitle' multiple times overrides previously-- set values.setTitleI::RenderMessagemastermsg=>msg->GWidgetsubmaster()setTitleImsg=domr<-liftgetMessageRendersetTitle$toHtml$mrmsg{-# DEPRECATED addHamletHead, addHtmlHead "Use toWidgetHead instead" #-}{-# DEPRECATED addHamlet, addHtml, addCassius, addLucius, addJulius "Use toWidget instead" #-}{-# DEPRECATED addJuliusBody "Use toWidgetBody instead" #-}{-# DEPRECATED addWidget "addWidget can be omitted" #-}-- | Add a 'Hamlet' to the head tag.addHamletHead::HtmlUrl(Routemaster)->GWidgetsubmaster()addHamletHead=toWidgetHead-- | Add a 'Html' to the head tag.addHtmlHead::Html->GWidgetsubmaster()addHtmlHead=toWidgetHead.const-- | Add a 'Hamlet' to the body tag.addHamlet::HtmlUrl(Routemaster)->GWidgetsubmaster()addHamlet=toWidget-- | Add a 'Html' to the body tag.addHtml::Html->GWidgetsubmaster()addHtml=toWidget-- | Add another widget. This is defined as 'id', by can help with types, and-- makes widget blocks look more consistent.addWidget::GWidgetsubmaster()->GWidgetsubmaster()addWidget=id-- | Add some raw CSS to the style tag. Applies to all media types.addCassius::CssUrl(Routemaster)->GWidgetsubmaster()addCassius=toWidget-- | Identical to 'addCassius'.addLucius::CssUrl(Routemaster)->GWidgetsubmaster()addLucius=toWidget-- | Add some raw CSS to the style tag, for a specific media type.addCassiusMedia::Text->CssUrl(Routemaster)->GWidgetsubmaster()addCassiusMediamx=tell$GWDatamemptymemptymemptymempty(Map.singleton(Justm)$\r->fromLazyText$renderCss$xr)memptymempty-- | Identical to 'addCassiusMedia'.addLuciusMedia::Text->CssUrl(Routemaster)->GWidgetsubmaster()addLuciusMedia=addCassiusMedia-- | Link to the specified local stylesheet.addStylesheet::Routemaster->GWidgetsubmaster()addStylesheet=flipaddStylesheetAttrs[]-- | Link to the specified local stylesheet.addStylesheetAttrs::Routemaster->[(Text,Text)]->GWidgetsubmaster()addStylesheetAttrsxy=tell$GWDatamemptymemptymempty(toUnique$Stylesheet(Localx)y)memptymemptymempty-- | Link to the specified remote stylesheet.addStylesheetRemote::Text->GWidgetsubmaster()addStylesheetRemote=flipaddStylesheetRemoteAttrs[]-- | Link to the specified remote stylesheet.addStylesheetRemoteAttrs::Text->[(Text,Text)]->GWidgetsubmaster()addStylesheetRemoteAttrsxy=tell$GWDatamemptymemptymempty(toUnique$Stylesheet(Remotex)y)memptymemptymemptyaddStylesheetEither::Either(Routemaster)Text->GWidgetsubmaster()addStylesheetEither=eitheraddStylesheetaddStylesheetRemoteaddScriptEither::Either(Routemaster)Text->GWidgetsubmaster()addScriptEither=eitheraddScriptaddScriptRemote-- | Link to the specified local script.addScript::Routemaster->GWidgetsubmaster()addScript=flipaddScriptAttrs[]-- | Link to the specified local script.addScriptAttrs::Routemaster->[(Text,Text)]->GWidgetsubmaster()addScriptAttrsxy=tell$GWDatamemptymempty(toUnique$Script(Localx)y)memptymemptymemptymempty-- | Link to the specified remote script.addScriptRemote::Text->GWidgetsubmaster()addScriptRemote=flipaddScriptRemoteAttrs[]-- | Link to the specified remote script.addScriptRemoteAttrs::Text->[(Text,Text)]->GWidgetsubmaster()addScriptRemoteAttrsxy=tell$GWDatamemptymempty(toUnique$Script(Remotex)y)memptymemptymemptymempty-- | Include raw Javascript in the page's script tag.addJulius::JavascriptUrl(Routemaster)->GWidgetsubmaster()addJulius=toWidget-- | Add a new script tag to the body with the contents of this 'Julius'-- template.addJuliusBody::JavascriptUrl(Routemaster)->GWidgetsubmaster()addJuliusBody=toWidgetBody-- | Content for a web page. By providing this datatype, we can easily create-- generic site templates, which would have the type signature:---- > PageContent url -> HtmlUrl urldataPageContenturl=PageContent{pageTitle::Html,pageHead::HtmlUrlurl,pageBody::HtmlUrlurl}whamlet::QuasiQuoterwhamlet=NP.hamletWithSettingsrulesNP.defaultHamletSettingswhamletFile::FilePath->QExpwhamletFile=NP.hamletFileWithSettingsrulesNP.defaultHamletSettingswhamletFileWithSettings::NP.HamletSettings->FilePath->QExpwhamletFileWithSettings=NP.hamletFileWithSettingsrulesrules::QNP.HamletRulesrules=doah<-[|toWidget|]lethelperqgf=dox<-newName"urender"e<-f$VarExlete'=LamE[VarPx]eg<-qgbind<-[|(>>=)|]return$InfixE(Justg)bind(Juste')leturf=doletenv=NP.Env(Just$helper[|liftWgetUrlRenderParams|])(Just$helper[|liftM(toHtml.)$liftWgetMessageRender|])fenvreturn$NP.HamletRulesahur$\_b->return$ah`AppE`b-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.ihamletToRepHtml::RenderMessagemastermessage=>HtmlUrlI18nmessage(Routemaster)->GHandlersubmasterRepHtmlihamletToRepHtmlih=dourender<-getUrlRenderParamsmrender<-getMessageRenderreturn$RepHtml$toContent$ih(toHtml.mrender)urendertell::GWData(Routemaster)->GWidgetsubmaster()tellw=GWidget$return((),w)instanceMonadLift(GHandlersubmaster)(GWidgetsubmaster)wherelift=GWidget.fmap(\x->(x,mempty))-- | Type-restricted version of @lift@liftW::GHandlersubmastera->GWidgetsubmasteraliftW=lift-- Instances for GWidgetinstanceFunctor(GWidgetsubmaster)wherefmapf(GWidgetx)=GWidget(fmap(firstf)x)instanceApplicative(GWidgetsubmaster)wherepurea=GWidget$pure(a,mempty)GWidgetf<*>GWidgetv=GWidget$k<$>f<*>vwherek(a,wa)(b,wb)=(ab,wa`mappend`wb)instanceMonad(GWidgetsubmaster)wherereturn=pureGWidgetx>>=f=GWidget$do(a,wa)<-x(b,wb)<-unGWidget(fa)return(b,wa`mappend`wb)instanceMonadIO(GWidgetsubmaster)whereliftIO=GWidget.fmap(\a->(a,mempty)).liftIOinstanceMonadBaseIO(GWidgetsubmaster)whereliftBase=GWidget.fmap(\a->(a,mempty)).liftBaseinstanceMonadBaseControlIO(GWidgetsubmaster)wheredataStM(GWidgetsubmaster)a=StW(StM(GHandlersubmaster)(a,GWData(Routemaster)))liftBaseWithf=GWidget$liftBaseWith$\runInBase->liftM(\x->(x,mempty))(f$liftMStW.runInBase.unGWidget)restoreM(StWbase)=GWidget$restoreMbaseinstanceMonadUnsafeIO(GWidgetsubmaster)whereunsafeLiftIO=liftIOinstanceMonadThrow(GWidgetsubmaster)wheremonadThrow=liftIO.throwIOinstanceMonadResource(GWidgetsubmaster)where#if MIN_VERSION_resourcet(0,4,0)liftResourceT=lift.liftResourceT#elseallocatea=lift.allocatearegister=lift.registerrelease=lift.releaseresourceMask=lift.resourceMask#endifinstanceMonadLogger(GWidgetsubmaster)wheremonadLoggerLogab=lift.monadLoggerLogabmonadLoggerLogSourceabc=lift.monadLoggerLogSourceabc