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