1{-# LANGUAGE GeneralizedNewtypeDeriving #-} 2{-# LANGUAGE TupleSections #-} 3{-# LANGUAGE RankNTypes #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE FlexibleInstances #-} 6{-# LANGUAGE TypeFamilies #-} 7{-# LANGUAGE TemplateHaskell #-} 8{-# LANGUAGE MultiParamTypeClasses #-} 9{-# LANGUAGE TypeSynonymInstances #-} 10{-# LANGUAGE UndecidableInstances #-} 11{-# LANGUAGE QuasiQuotes #-} 12 13-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier 14-- generator, allowing you to create truly modular HTML components. 15module Yesod.Core.Widget 16 ( -- * Datatype 17 WidgetT 18 , WidgetFor 19 , PageContent (..) 20 -- * Special Hamlet quasiquoter/TH for Widgets 21 , whamlet 22 , whamletFile 23 , ihamletToRepHtml 24 , ihamletToHtml 25 -- * Convert to Widget 26 , ToWidget (..) 27 , ToWidgetHead (..) 28 , ToWidgetBody (..) 29 , ToWidgetMedia (..) 30 -- * Creating 31 -- ** Head of page 32 , setTitle 33 , setTitleI 34 , setDescription 35 , setDescriptionI 36 , setOGType 37 , setOGImage 38 -- ** CSS 39 , addStylesheet 40 , addStylesheetAttrs 41 , addStylesheetRemote 42 , addStylesheetRemoteAttrs 43 , addStylesheetEither 44 , CssBuilder (..) 45 -- ** Javascript 46 , addScript 47 , addScriptAttrs 48 , addScriptRemote 49 , addScriptRemoteAttrs 50 , addScriptEither 51 -- * Subsites 52 , handlerToWidget 53 -- * Internal 54 , whamletFileWithSettings 55 , asWidgetT 56 ) where 57 58import Data.Monoid 59import qualified Text.Blaze.Html5 as H 60import Text.Hamlet 61import Text.Cassius 62import Text.Julius 63import Yesod.Routes.Class 64import Yesod.Core.Handler (getMessageRender, getUrlRenderParams) 65import Text.Shakespeare.I18N (RenderMessage) 66import Data.Text (Text) 67import qualified Data.Map as Map 68import Language.Haskell.TH.Quote (QuasiQuoter) 69import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName) 70 71import qualified Text.Hamlet as NP 72import Data.Text.Lazy.Builder (fromLazyText) 73import Text.Blaze.Html (toHtml, preEscapedToMarkup) 74import qualified Data.Text.Lazy as TL 75import qualified Data.Text.Lazy.Builder as TB 76 77import Yesod.Core.Types 78import Yesod.Core.Class.Handler 79 80type WidgetT site (m :: * -> *) = WidgetFor site 81{-# DEPRECATED WidgetT "Use WidgetFor directly" #-} 82 83preEscapedLazyText :: TL.Text -> Html 84preEscapedLazyText = preEscapedToMarkup 85 86class ToWidget site a where 87 toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m () 88 89instance render ~ RY site => ToWidget site (render -> Html) where 90 toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty 91instance render ~ RY site => ToWidget site (render -> Css) where 92 toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x 93instance ToWidget site Css where 94 toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x 95instance render ~ RY site => ToWidget site (render -> CssBuilder) where 96 toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty 97instance ToWidget site CssBuilder where 98 toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty 99instance render ~ RY site => ToWidget site (render -> Javascript) where 100 toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty 101instance ToWidget site Javascript where 102 toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty 103instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where 104 toWidget = liftWidget 105instance ToWidget site Html where 106 toWidget = toWidget . const 107-- | @since 1.4.28 108instance ToWidget site Text where 109 toWidget = toWidget . toHtml 110-- | @since 1.4.28 111instance ToWidget site TL.Text where 112 toWidget = toWidget . toHtml 113-- | @since 1.4.28 114instance ToWidget site TB.Builder where 115 toWidget = toWidget . toHtml 116 117-- | Allows adding some CSS to the page with a specific media type. 118-- 119-- Since 1.2 120class ToWidgetMedia site a where 121 -- | Add the given content to the page, but only for the given media type. 122 -- 123 -- Since 1.2 124 toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site) 125 => Text -- ^ media value 126 -> a 127 -> m () 128instance render ~ RY site => ToWidgetMedia site (render -> Css) where 129 toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x 130instance ToWidgetMedia site Css where 131 toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x 132instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where 133 toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty 134instance ToWidgetMedia site CssBuilder where 135 toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty 136 137class ToWidgetBody site a where 138 toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m () 139 140instance render ~ RY site => ToWidgetBody site (render -> Html) where 141 toWidgetBody = toWidget 142instance render ~ RY site => ToWidgetBody site (render -> Javascript) where 143 toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j 144instance ToWidgetBody site Javascript where 145 toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j 146instance ToWidgetBody site Html where 147 toWidgetBody = toWidget 148 149class ToWidgetHead site a where 150 toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m () 151 152instance render ~ RY site => ToWidgetHead site (render -> Html) where 153 toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head 154instance render ~ RY site => ToWidgetHead site (render -> Css) where 155 toWidgetHead = toWidget 156instance ToWidgetHead site Css where 157 toWidgetHead = toWidget 158instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where 159 toWidgetHead = toWidget 160instance ToWidgetHead site CssBuilder where 161 toWidgetHead = toWidget 162instance render ~ RY site => ToWidgetHead site (render -> Javascript) where 163 toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j 164instance ToWidgetHead site Javascript where 165 toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j 166instance ToWidgetHead site Html where 167 toWidgetHead = toWidgetHead . const 168 169-- | Set the page title. 170-- 171-- Calling @setTitle@ or @setTitleI@ multiple times overrides previously set 172-- values. 173-- 174-- SEO Notes: 175-- 176-- * Title tags are the second most important on-page factor for SEO, after 177-- content 178-- * Every page should have a unique title tag 179-- * Start your title tag with your main targeted keyword 180-- * Don't stuff your keywords 181-- * Google typically shows 55-64 characters, so aim to keep your title 182-- length under 60 characters 183setTitle :: MonadWidget m => Html -> m () 184setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty 185 186-- | Set the localised page title. 187-- 188-- n.b. See comments for @setTitle@ 189setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m () 190setTitleI msg = do 191 mr <- getMessageRender 192 setTitle $ toHtml $ mr msg 193 194-- | Add description meta tag to the head of the page 195-- 196-- Google does not use the description tag as a ranking signal, but the 197-- contents of this tag will likely affect your click-through rate since it 198-- shows up in search results. 199-- 200-- The average length of the description shown in Google's search results is 201-- about 160 characters on desktop, and about 130 characters on mobile, at time 202-- of writing. 203-- 204-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/ 205-- 206-- @since 1.6.18 207setDescription :: MonadWidget m => Text -> m () 208setDescription description = 209 toWidgetHead $ [hamlet|<meta name=description content=#{description}>|] 210 211-- | Add translated description meta tag to the head of the page 212-- 213-- n.b. See comments for @setDescription@. 214-- 215-- @since 1.6.18 216setDescriptionI 217 :: (MonadWidget m, RenderMessage (HandlerSite m) msg) 218 => msg -> m () 219setDescriptionI msg = do 220 mr <- getMessageRender 221 toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|] 222 223-- | Add OpenGraph type meta tag to the head of the page 224-- 225-- See all available OG types here: https://ogp.me/#types 226-- 227-- @since 1.6.18 228setOGType :: MonadWidget m => Text -> m () 229setOGType a = toWidgetHead $ [hamlet|<meta name="og:type" content=#{a}>|] 230 231-- | Add OpenGraph image meta tag to the head of the page 232-- 233-- Best practices: 234-- 235-- * Use custom images for shareable pages, e.g., homepage, articles, etc. 236-- * Use your logo or any other branded image for the rest of your pages. 237-- * Use images with a 1.91:1 ratio and minimum recommended dimensions of 238-- 1200x630 for optimal clarity across all devices. 239-- 240-- Source: https://ahrefs.com/blog/open-graph-meta-tags/ 241-- 242-- @since 1.6.18 243setOGImage :: MonadWidget m => Text -> m () 244setOGImage a = toWidgetHead $ [hamlet|<meta name="og:image" content=#{a}>|] 245 246-- | Link to the specified local stylesheet. 247addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m () 248addStylesheet = flip addStylesheetAttrs [] 249 250-- | Link to the specified local stylesheet. 251addStylesheetAttrs :: MonadWidget m 252 => Route (HandlerSite m) 253 -> [(Text, Text)] 254 -> m () 255addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty 256 257-- | Link to the specified remote stylesheet. 258addStylesheetRemote :: MonadWidget m => Text -> m () 259addStylesheetRemote = flip addStylesheetRemoteAttrs [] 260 261-- | Link to the specified remote stylesheet. 262addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () 263addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty 264 265addStylesheetEither :: MonadWidget m 266 => Either (Route (HandlerSite m)) Text 267 -> m () 268addStylesheetEither = either addStylesheet addStylesheetRemote 269 270addScriptEither :: MonadWidget m 271 => Either (Route (HandlerSite m)) Text 272 -> m () 273addScriptEither = either addScript addScriptRemote 274 275-- | Link to the specified local script. 276addScript :: MonadWidget m => Route (HandlerSite m) -> m () 277addScript = flip addScriptAttrs [] 278 279-- | Link to the specified local script. 280addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m () 281addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty 282 283-- | Link to the specified remote script. 284addScriptRemote :: MonadWidget m => Text -> m () 285addScriptRemote = flip addScriptRemoteAttrs [] 286 287-- | Link to the specified remote script. 288addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () 289addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty 290 291whamlet :: QuasiQuoter 292whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings 293 294whamletFile :: FilePath -> Q Exp 295whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings 296 297whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp 298whamletFileWithSettings = NP.hamletFileWithSettings rules 299 300asWidgetT :: WidgetT site m () -> WidgetT site m () 301asWidgetT = id 302 303rules :: Q NP.HamletRules 304rules = do 305 ah <- [|asWidgetT . toWidget|] 306 let helper qg f = do 307 x <- newName "urender" 308 e <- f $ VarE x 309 let e' = LamE [VarP x] e 310 g <- qg 311 bind <- [|(>>=)|] 312 return $ InfixE (Just g) bind (Just e') 313 let ur f = do 314 let env = NP.Env 315 (Just $ helper [|getUrlRenderParams|]) 316 (Just $ helper [|fmap (toHtml .) getMessageRender|]) 317 f env 318 return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b 319 320-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. 321ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) 322 => HtmlUrlI18n message (Route (HandlerSite m)) 323 -> m Html 324ihamletToRepHtml = ihamletToHtml 325{-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-} 326 327-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. 328-- 329-- Since 1.2.1 330ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message) 331 => HtmlUrlI18n message (Route (HandlerSite m)) 332 -> m Html 333ihamletToHtml ih = do 334 urender <- getUrlRenderParams 335 mrender <- getMessageRender 336 return $ ih (toHtml . mrender) urender 337 338tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m () 339tell = liftWidget . tellWidget 340 341toUnique :: x -> UniqueList x 342toUnique = UniqueList . (:) 343 344handlerToWidget :: HandlerFor site a -> WidgetFor site a 345handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler 346