Widgets should have an interface for templates
Move shakespeare specific stuff to Yesod.Shakespeare I have not bothered to make Yesod.Shakespeare compile yet The dependency chain is now Yesod.Core -> Yesod.Widget -> Yesod.Shakespeare
This commit is contained in:
Greg Weber
parent
458f1abcd2
commit
aabb126d63
@ -298,6 +298,7 @@ data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttribute
|
||||
newtype Title = Title { unTitle :: Html }
|
||||
|
||||
type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
|
||||
type BuilderUrl url = (url -> [(Text, Text)] -> Text) -> TBuilder.Builder
|
||||
|
||||
data HandlerContents =
|
||||
HCContent H.Status !TypedContent
|
||||
|
||||
@ -20,11 +20,6 @@ module Yesod.Core.Widget
|
||||
( -- * Datatype
|
||||
WidgetT(..)
|
||||
, PageContent (..)
|
||||
-- * Special Hamlet quasiquoter/TH for Widgets
|
||||
, whamlet
|
||||
, whamletFile
|
||||
, ihamletToRepHtml
|
||||
, ihamletToHtml
|
||||
-- * Convert to Widget
|
||||
, ToWidget (..)
|
||||
, ToWidgetHead (..)
|
||||
@ -33,7 +28,6 @@ module Yesod.Core.Widget
|
||||
-- * Creating
|
||||
-- ** Head of page
|
||||
, setTitle
|
||||
, setTitleI
|
||||
-- ** CSS
|
||||
, addStylesheet
|
||||
, addStylesheetAttrs
|
||||
@ -51,7 +45,6 @@ module Yesod.Core.Widget
|
||||
, widgetToParentWidget
|
||||
, handlerToWidget
|
||||
-- * Internal
|
||||
, whamletFileWithSettings
|
||||
, asWidgetT
|
||||
|
||||
-- * Formerly Yesod.Core.Types
|
||||
@ -61,30 +54,16 @@ module Yesod.Core.Widget
|
||||
, Head(..)
|
||||
, Body(..)
|
||||
|
||||
-- * Formerly Yesod.Core.Class.Yesod
|
||||
, jelper
|
||||
, asyncHelper
|
||||
, jsToHtml
|
||||
|
||||
-- * Formerly Yesod.Core.Class.Handler
|
||||
|
||||
-- * Formerly Yesod.Core.Handler
|
||||
-- ** Streaming
|
||||
, sendChunkHtml
|
||||
-- ** Redirecting
|
||||
, redirectToPost
|
||||
-- ** Errors
|
||||
, permissionDeniedI
|
||||
, invalidArgsI
|
||||
, unauthorizedI
|
||||
-- ** Messages
|
||||
, setMessage
|
||||
, setMessageI
|
||||
, getMessage
|
||||
-- ** Hamlet
|
||||
, hamletToRepHtml
|
||||
-- * i18n
|
||||
, getMessageRender
|
||||
|
||||
-- * Formerly Yesod.Core.Json
|
||||
-- FIXME
|
||||
@ -128,22 +107,16 @@ import Data.Monoid
|
||||
import Data.Semigroup (Semigroup)
|
||||
import qualified Data.Text as T
|
||||
import qualified Text.Blaze.Html.Renderer.Text as RenderText
|
||||
import Text.Blaze.Html (preEscapedToMarkup, toHtml)
|
||||
import Text.Blaze.Html (preEscapedToMarkup, toHtml, Html)
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
||||
import Text.Hamlet
|
||||
import Text.Cassius
|
||||
import Text.Julius
|
||||
import Text.Shakespeare.I18N (renderMessage)
|
||||
import Yesod.Routes.Class
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Text.Shakespeare.I18N (RenderMessage)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Map as Map
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
|
||||
|
||||
import qualified Text.Hamlet as NP
|
||||
import Data.Text.Lazy.Builder (fromLazyText, toLazyText)
|
||||
import System.Log.FastLogger (toLogStr)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
@ -157,6 +130,17 @@ import Yesod.Core.Content (ToContent(..), ToTypedContent(..), HasContentType(..)
|
||||
import Data.Map (Map, unionWith)
|
||||
import qualified Data.Aeson as J
|
||||
|
||||
-- templating types
|
||||
class ToWidgetBuilder a where
|
||||
toWidgetBuilder :: a -> Builder
|
||||
|
||||
type Render url = url -> [(Text, Text)] -> Text
|
||||
type Translate msg = msg -> Html
|
||||
type HtmlUrl url = Render url -> Html
|
||||
type HtmlUrlI18n msg url = Translate msg -> Render url -> Html
|
||||
|
||||
|
||||
|
||||
------------------------------------
|
||||
-- Original Yesod.Core.Widget
|
||||
------------------------------------
|
||||
@ -168,18 +152,10 @@ class ToWidget site a where
|
||||
|
||||
instance render ~ RY site => ToWidget site (render -> Html) where
|
||||
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
|
||||
instance render ~ RY site => ToWidget site (render -> Css) where
|
||||
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
|
||||
instance ToWidget site Css where
|
||||
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x
|
||||
instance render ~ RY site => ToWidget site (render -> CssBuilder) where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
|
||||
instance ToWidget site CssBuilder where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
|
||||
instance render ~ RY site => ToWidget site (render -> Javascript) where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
|
||||
instance ToWidget site Javascript where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty
|
||||
instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where
|
||||
toWidget = liftWidgetT
|
||||
instance ToWidget site Html where
|
||||
@ -196,10 +172,6 @@ class ToWidgetMedia site a where
|
||||
=> Text -- ^ media value
|
||||
-> a
|
||||
-> m ()
|
||||
instance render ~ RY site => ToWidgetMedia site (render -> Css) where
|
||||
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
|
||||
instance ToWidgetMedia site Css where
|
||||
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
|
||||
instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
|
||||
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
|
||||
instance ToWidgetMedia site CssBuilder where
|
||||
@ -210,10 +182,6 @@ class ToWidgetBody site a where
|
||||
|
||||
instance render ~ RY site => ToWidgetBody site (render -> Html) where
|
||||
toWidgetBody = toWidget
|
||||
instance render ~ RY site => ToWidgetBody site (render -> Javascript) where
|
||||
toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
|
||||
instance ToWidgetBody site Javascript where
|
||||
toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
|
||||
instance ToWidgetBody site Html where
|
||||
toWidgetBody = toWidget
|
||||
|
||||
@ -222,33 +190,12 @@ class ToWidgetHead site a where
|
||||
|
||||
instance render ~ RY site => ToWidgetHead site (render -> Html) where
|
||||
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
|
||||
instance render ~ RY site => ToWidgetHead site (render -> Css) where
|
||||
toWidgetHead = toWidget
|
||||
instance ToWidgetHead site Css where
|
||||
toWidgetHead = toWidget
|
||||
instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where
|
||||
toWidgetHead = toWidget
|
||||
instance ToWidgetHead site CssBuilder where
|
||||
toWidgetHead = toWidget
|
||||
instance render ~ RY site => ToWidgetHead site (render -> Javascript) where
|
||||
toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
|
||||
instance ToWidgetHead site Javascript where
|
||||
toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
|
||||
instance ToWidgetHead site Html where
|
||||
toWidgetHead = toWidgetHead . const
|
||||
|
||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
||||
-- set values.
|
||||
setTitle :: MonadWidget m => Html -> m ()
|
||||
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
||||
-- set values.
|
||||
setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
|
||||
setTitleI msg = do
|
||||
mr <- getMessageRender
|
||||
setTitle $ toHtml $ mr msg
|
||||
|
||||
-- | Link to the specified local stylesheet.
|
||||
addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
|
||||
addStylesheet = flip addStylesheetAttrs []
|
||||
@ -294,53 +241,6 @@ addScriptRemote = flip addScriptRemoteAttrs []
|
||||
addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
|
||||
addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
|
||||
whamlet :: QuasiQuoter
|
||||
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
|
||||
|
||||
whamletFile :: FilePath -> Q Exp
|
||||
whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
|
||||
|
||||
whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp
|
||||
whamletFileWithSettings = NP.hamletFileWithSettings rules
|
||||
|
||||
asWidgetT :: WidgetT site m () -> WidgetT site m ()
|
||||
asWidgetT = id
|
||||
|
||||
rules :: Q NP.HamletRules
|
||||
rules = do
|
||||
ah <- [|asWidgetT . toWidget|]
|
||||
let helper qg f = do
|
||||
x <- newName "urender"
|
||||
e <- f $ VarE x
|
||||
let e' = LamE [VarP x] e
|
||||
g <- qg
|
||||
bind <- [|(>>=)|]
|
||||
return $ InfixE (Just g) bind (Just e')
|
||||
let ur f = do
|
||||
let env = NP.Env
|
||||
(Just $ helper [|getUrlRenderParams|])
|
||||
(Just $ helper [|liftM (toHtml .) getMessageRender|])
|
||||
f env
|
||||
return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
|
||||
=> HtmlUrlI18n message (Route (HandlerSite m))
|
||||
-> m Html
|
||||
ihamletToRepHtml = ihamletToHtml
|
||||
{-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-}
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
--
|
||||
-- Since 1.2.1
|
||||
ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
|
||||
=> HtmlUrlI18n message (Route (HandlerSite m))
|
||||
-> m Html
|
||||
ihamletToHtml ih = do
|
||||
urender <- getUrlRenderParams
|
||||
mrender <- getMessageRender
|
||||
return $ ih (toHtml . mrender) urender
|
||||
|
||||
tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
|
||||
tell w = liftWidgetT $ WidgetT $ const $ return ((), w)
|
||||
|
||||
@ -396,7 +296,7 @@ data GWData a = GWData
|
||||
, gwdScripts :: !(UniqueList (Script a))
|
||||
, gwdStylesheets :: !(UniqueList (Stylesheet a))
|
||||
, gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
|
||||
, gwdJavascript :: !(Maybe (JavascriptUrl a))
|
||||
, gwdJavascript :: !(Maybe (BuilderUrl a))
|
||||
, gwdHead :: !(Head a)
|
||||
}
|
||||
instance Monoid (GWData a) where
|
||||
@ -503,6 +403,10 @@ instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
|
||||
mappend x y = x >> y
|
||||
instance (a ~ (), Monad m) => Semigroup (WidgetT site m a)
|
||||
|
||||
asWidgetT :: WidgetT site m () -> WidgetT site m ()
|
||||
asWidgetT = id
|
||||
|
||||
|
||||
-- | Content for a web page. By providing this datatype, we can easily create
|
||||
-- generic site templates, which would have the type signature:
|
||||
--
|
||||
@ -527,25 +431,13 @@ instance Semigroup (Body a)
|
||||
------------------------------------
|
||||
instance ToContent Html where
|
||||
toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
|
||||
instance ToContent Css where
|
||||
toContent = toContent . renderCss
|
||||
instance ToContent Javascript where
|
||||
toContent = toContent . toLazyText . unJavascript
|
||||
instance ToTypedContent Html where
|
||||
toTypedContent h = TypedContent typeHtml (toContent h)
|
||||
instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder
|
||||
instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder
|
||||
instance ToTypedContent Css where
|
||||
toTypedContent = TypedContent typeCss . toContent
|
||||
instance ToTypedContent Javascript where
|
||||
toTypedContent = TypedContent typeJavascript . toContent
|
||||
|
||||
instance HasContentType Html where
|
||||
getContentType _ = typeHtml
|
||||
instance HasContentType Css where
|
||||
getContentType _ = typeCss
|
||||
instance HasContentType Javascript where
|
||||
getContentType _ = typeJavascript
|
||||
|
||||
------------------------------------
|
||||
-- Formerly Yesod.Core.Class.Handler
|
||||
@ -593,15 +485,6 @@ msgKey = T.pack "_MSG"
|
||||
setMessage :: MonadHandler m => Html -> m ()
|
||||
setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
|
||||
|
||||
-- | Sets a message in the user's session.
|
||||
--
|
||||
-- See 'getMessage'.
|
||||
setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
|
||||
=> msg -> m ()
|
||||
setMessageI msg = do
|
||||
mr <- getMessageRender
|
||||
setMessage $ toHtml $ mr msg
|
||||
|
||||
-- | Gets the message in the user's session, if available, and then clears the
|
||||
-- variable.
|
||||
--
|
||||
@ -612,58 +495,11 @@ getMessage = do
|
||||
deleteSession msgKey
|
||||
return mmsg
|
||||
|
||||
-- | Return a 403 permission denied page.
|
||||
permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m)
|
||||
=> msg
|
||||
-> m a
|
||||
permissionDeniedI msg = do
|
||||
mr <- getMessageRender
|
||||
permissionDenied $ mr msg
|
||||
|
||||
-- | Return a 400 invalid arguments page.
|
||||
invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
|
||||
invalidArgsI msg = do
|
||||
mr <- getMessageRender
|
||||
invalidArgs $ map mr msg
|
||||
|
||||
-- | Redirect to a POST resource.
|
||||
--
|
||||
-- This is not technically a redirect; instead, it returns an HTML page with a
|
||||
-- POST form, and some Javascript to automatically submit the form. This can be
|
||||
-- useful when you need to post a plain link somewhere that needs to cause
|
||||
-- changes on the server.
|
||||
redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
|
||||
=> url
|
||||
-> m a
|
||||
redirectToPost url = do
|
||||
urlText <- toTextUrl url
|
||||
withUrlRenderer [hamlet|
|
||||
$newline never
|
||||
$doctype 5
|
||||
|
||||
<html>
|
||||
<head>
|
||||
<title>Redirecting...
|
||||
<body onload="document.getElementById('form').submit()">
|
||||
<form id="form" method="post" action=#{urlText}>
|
||||
<noscript>
|
||||
<p>Javascript has been disabled; please click on the button below to be redirected.
|
||||
<input type="submit" value="Continue">
|
||||
|] >>= sendResponse
|
||||
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html
|
||||
hamletToRepHtml = withUrlRenderer
|
||||
{-# DEPRECATED hamletToRepHtml "Use withUrlRenderer instead" #-}
|
||||
|
||||
getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)
|
||||
=> m (message -> Text)
|
||||
getMessageRender = do
|
||||
site <- getYesod
|
||||
l <- reqLangs `liftM` getRequest
|
||||
return $ renderMessage site l
|
||||
|
||||
-- | Type-specialized version of 'sendChunk' for @Html@s.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
@ -671,162 +507,6 @@ sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
|
||||
sendChunkHtml = sendChunk
|
||||
|
||||
|
||||
------------------------------
|
||||
-- from Yesod.Core.Class.Yesod
|
||||
------------------------------
|
||||
type AddStaticContent site = Text -- ^ filename extension
|
||||
-> Text -- ^ mime-type
|
||||
-> L.ByteString -- ^ content
|
||||
-> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
|
||||
|
||||
-- | Convert a widget to a 'PageContent'.
|
||||
-- not bound to the Yesod typeclass
|
||||
{- widgetToPageContentUnbound
|
||||
:: (MonadBaseControl IO m, MonadThrow m, MonadIO m, Eq (Route site))
|
||||
=> AddStaticContent site -> site -> ScriptLoadPosition site -> WidgetT site IO ()
|
||||
-> HandlerT site m (PageContent (Route site))
|
||||
-}
|
||||
widgetToPageContentUnbound addStaticContent jsLoader w = do
|
||||
master <- getYesod
|
||||
hd <- HandlerT return
|
||||
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
|
||||
let title = maybe mempty unTitle mTitle
|
||||
scripts = runUniqueList scripts'
|
||||
stylesheets = runUniqueList stylesheets'
|
||||
|
||||
render <- getUrlRenderParams
|
||||
let renderLoc x =
|
||||
case x of
|
||||
Nothing -> Nothing
|
||||
Just (Left s) -> Just s
|
||||
Just (Right (u, p)) -> Just $ render u p
|
||||
css <- forM (Map.toList style) $ \(mmedia, content) -> do
|
||||
let rendered = toLazyText $ content render
|
||||
x <- addStaticContent "css" "text/css; charset=utf-8"
|
||||
$ encodeUtf8 rendered
|
||||
return (mmedia,
|
||||
case x of
|
||||
Nothing -> Left $ preEscapedToMarkup rendered
|
||||
Just y -> Right $ either id (uncurry render) y)
|
||||
jsLoc <-
|
||||
case jscript of
|
||||
Nothing -> return Nothing
|
||||
Just s -> do
|
||||
x <- addStaticContent "js" "text/javascript; charset=utf-8"
|
||||
$ encodeUtf8 $ renderJavascriptUrl render s
|
||||
return $ renderLoc x
|
||||
|
||||
-- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
|
||||
-- the asynchronous loader means your page doesn't have to wait for all the js to load
|
||||
let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
|
||||
regularScriptLoad = [hamlet|
|
||||
$newline never
|
||||
$forall s <- scripts
|
||||
^{mkScriptTag s}
|
||||
$maybe j <- jscript
|
||||
$maybe s <- jsLoc
|
||||
<script src="#{s}">
|
||||
$nothing
|
||||
<script>^{jelper j}
|
||||
|]
|
||||
|
||||
headAll = [hamlet|
|
||||
$newline never
|
||||
\^{head'}
|
||||
$forall s <- stylesheets
|
||||
^{mkLinkTag s}
|
||||
$forall s <- css
|
||||
$maybe t <- right $ snd s
|
||||
$maybe media <- fst s
|
||||
<link rel=stylesheet media=#{media} href=#{t}>
|
||||
$nothing
|
||||
<link rel=stylesheet href=#{t}>
|
||||
$maybe content <- left $ snd s
|
||||
$maybe media <- fst s
|
||||
<style media=#{media}>#{content}
|
||||
$nothing
|
||||
<style>#{content}
|
||||
$case jsLoader master
|
||||
$of BottomOfBody
|
||||
$of BottomOfHeadAsync asyncJsLoader
|
||||
^{asyncJsLoader asyncScripts mcomplete}
|
||||
$of BottomOfHeadBlocking
|
||||
^{regularScriptLoad}
|
||||
|]
|
||||
let bodyScript = [hamlet|
|
||||
$newline never
|
||||
^{body}
|
||||
^{regularScriptLoad}
|
||||
|]
|
||||
|
||||
return $ PageContent title headAll $
|
||||
case jsLoader master of
|
||||
BottomOfBody -> bodyScript
|
||||
_ -> body
|
||||
where
|
||||
renderLoc' render' (Local url) = render' url []
|
||||
renderLoc' _ (Remote s) = s
|
||||
|
||||
addAttr x (y, z) = x H.! H.customAttribute (H.textTag y) (H.toValue z)
|
||||
mkScriptTag (Script loc attrs) render' =
|
||||
foldl' addAttr H.script (("src", renderLoc' render' loc) : attrs) $ return ()
|
||||
mkLinkTag (Stylesheet loc attrs) render' =
|
||||
foldl' addAttr H.link
|
||||
( ("rel", "stylesheet")
|
||||
: ("href", renderLoc' render' loc)
|
||||
: attrs
|
||||
)
|
||||
|
||||
runUniqueList :: Eq x => UniqueList x -> [x]
|
||||
runUniqueList (UniqueList x) = nub $ x []
|
||||
|
||||
asyncHelper :: (url -> [x] -> Text)
|
||||
-> [Script (url)]
|
||||
-> Maybe (JavascriptUrl (url))
|
||||
-> Maybe Text
|
||||
-> (Maybe (HtmlUrl url), [Text])
|
||||
asyncHelper render scripts jscript jsLoc =
|
||||
(mcomplete, scripts'')
|
||||
where
|
||||
scripts' = map goScript scripts
|
||||
scripts'' =
|
||||
case jsLoc of
|
||||
Just s -> scripts' ++ [s]
|
||||
Nothing -> scripts'
|
||||
goScript (Script (Local url) _) = render url []
|
||||
goScript (Script (Remote s) _) = s
|
||||
mcomplete =
|
||||
case jsLoc of
|
||||
Just{} -> Nothing
|
||||
Nothing ->
|
||||
case jscript of
|
||||
Nothing -> Nothing
|
||||
Just j -> Just $ jelper j
|
||||
|
||||
jsToHtml :: Javascript -> Html
|
||||
jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
|
||||
|
||||
jelper :: JavascriptUrl url -> HtmlUrl url
|
||||
jelper = fmap jsToHtml
|
||||
|
||||
right :: Either a b -> Maybe b
|
||||
right (Right x) = Just x
|
||||
right _ = Nothing
|
||||
|
||||
left :: Either a b -> Maybe a
|
||||
left (Left x) = Just x
|
||||
left _ = Nothing
|
||||
|
||||
|
||||
-----------------------------
|
||||
-- originally from Yesod.Core
|
||||
-----------------------------
|
||||
-- | Return an 'Unauthorized' value, with the given i18n message.
|
||||
unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult
|
||||
unauthorizedI msg = do
|
||||
mr <- getMessageRender
|
||||
return $ Unauthorized $ mr msg
|
||||
|
||||
-----------------------------
|
||||
-- originally from Yesod.Core.Json
|
||||
-----------------------------
|
||||
@ -835,7 +515,7 @@ unauthorizedI msg = do
|
||||
-- ('defaultLayout').
|
||||
--
|
||||
-- /Since: 0.3.0/
|
||||
{-
|
||||
{- FIXME
|
||||
defaultLayoutJson :: (Yesod site, J.ToJSON a)
|
||||
=> WidgetT site IO () -- ^ HTML
|
||||
-> HandlerT site IO a -- ^ JSON
|
||||
|
||||
365
yesod-core/Yesod/Shakespeare.hs
Normal file
365
yesod-core/Yesod/Shakespeare.hs
Normal file
@ -0,0 +1,365 @@
|
||||
module Yesod.Shakespeare (
|
||||
, whamlet
|
||||
, whamletFile
|
||||
-- * Special Hamlet quasiquoter/TH for Widgets
|
||||
, ihamletToRepHtml
|
||||
, ihamletToHtml
|
||||
-- * Internal
|
||||
, whamletFileWithSettings
|
||||
-- * Creating
|
||||
-- ** Head of page
|
||||
, setTitleI
|
||||
-- ** Errors
|
||||
, permissionDeniedI
|
||||
, invalidArgsI
|
||||
, unauthorizedI
|
||||
-- ** Messages
|
||||
, setMessageI
|
||||
-- * i18n
|
||||
, getMessageRender
|
||||
|
||||
-- * Formerly Yesod.Core.Class.Yesod
|
||||
, jelper
|
||||
, asyncHelper
|
||||
, jsToHtml
|
||||
-- * Formerly Yesod.Core.Handler
|
||||
-- ** Redirecting
|
||||
, redirectToPost
|
||||
|
||||
-- * Shakespeare
|
||||
-- ** Hamlet
|
||||
, hamlet
|
||||
, shamlet
|
||||
, xhamlet
|
||||
, HtmlUrl
|
||||
-- ** Julius
|
||||
, julius
|
||||
, JavascriptUrl
|
||||
, renderJavascriptUrl
|
||||
-- ** Cassius/Lucius
|
||||
, cassius
|
||||
, lucius
|
||||
, CssUrl
|
||||
, renderCssUrl
|
||||
) where
|
||||
|
||||
import Yesod.Core.Widget
|
||||
import Text.Shakespeare.I18N
|
||||
|
||||
instance ToWidgetBuilder Javascript where
|
||||
toWidgetBuilder = unJavascript
|
||||
|
||||
whamlet :: QuasiQuoter
|
||||
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
|
||||
|
||||
whamletFile :: FilePath -> Q Exp
|
||||
whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
|
||||
|
||||
whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp
|
||||
whamletFileWithSettings = NP.hamletFileWithSettings rules
|
||||
|
||||
rules :: Q NP.HamletRules
|
||||
rules = do
|
||||
ah <- [|asWidgetT . toWidget|]
|
||||
let helper qg f = do
|
||||
x <- newName "urender"
|
||||
e <- f $ VarE x
|
||||
let e' = LamE [VarP x] e
|
||||
g <- qg
|
||||
bind <- [|(>>=)|]
|
||||
return $ InfixE (Just g) bind (Just e')
|
||||
let ur f = do
|
||||
let env = NP.Env
|
||||
(Just $ helper [|getUrlRenderParams|])
|
||||
(Just $ helper [|liftM (toHtml .) getMessageRender|])
|
||||
f env
|
||||
return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
|
||||
=> HtmlUrlI18n message (Route (HandlerSite m))
|
||||
-> m Html
|
||||
ihamletToRepHtml = ihamletToHtml
|
||||
{-# DEPRECATED ihamletToRepHtml "Please use ihamletToHtml instead" #-}
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
--
|
||||
-- Since 1.2.1
|
||||
ihamletToHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
|
||||
=> HtmlUrlI18n message (Route (HandlerSite m))
|
||||
-> m Html
|
||||
ihamletToHtml ih = do
|
||||
urender <- getUrlRenderParams
|
||||
mrender <- getMessageRender
|
||||
return $ ih (toHtml . mrender) urender
|
||||
|
||||
|
||||
-- | Redirect to a POST resource.
|
||||
--
|
||||
-- This is not technically a redirect; instead, it returns an HTML page with a
|
||||
-- POST form, and some Javascript to automatically submit the form. This can be
|
||||
-- useful when you need to post a plain link somewhere that needs to cause
|
||||
-- changes on the server.
|
||||
redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
|
||||
=> url
|
||||
-> m a
|
||||
redirectToPost url = do
|
||||
urlText <- toTextUrl url
|
||||
withUrlRenderer [hamlet|
|
||||
$newline never
|
||||
$doctype 5
|
||||
|
||||
<html>
|
||||
<head>
|
||||
<title>Redirecting...
|
||||
<body onload="document.getElementById('form').submit()">
|
||||
<form id="form" method="post" action=#{urlText}>
|
||||
<noscript>
|
||||
<p>Javascript has been disabled; please click on the button below to be redirected.
|
||||
<input type="submit" value="Continue">
|
||||
|] >>= sendResponse
|
||||
|
||||
------------------------------
|
||||
-- from Yesod.Core.Class.Yesod
|
||||
------------------------------
|
||||
type AddStaticContent site = Text -- ^ filename extension
|
||||
-> Text -- ^ mime-type
|
||||
-> L.ByteString -- ^ content
|
||||
-> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
|
||||
|
||||
-- | Convert a widget to a 'PageContent'.
|
||||
-- not bound to the Yesod typeclass
|
||||
{- widgetToPageContentUnbound
|
||||
:: (MonadBaseControl IO m, MonadThrow m, MonadIO m, Eq (Route site))
|
||||
=> AddStaticContent site -> site -> ScriptLoadPosition site -> WidgetT site IO ()
|
||||
-> HandlerT site m (PageContent (Route site))
|
||||
-}
|
||||
widgetToPageContentUnbound addStaticContent jsLoader w = do
|
||||
master <- getYesod
|
||||
hd <- HandlerT return
|
||||
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
|
||||
let title = maybe mempty unTitle mTitle
|
||||
scripts = runUniqueList scripts'
|
||||
stylesheets = runUniqueList stylesheets'
|
||||
|
||||
render <- getUrlRenderParams
|
||||
let renderLoc x =
|
||||
case x of
|
||||
Nothing -> Nothing
|
||||
Just (Left s) -> Just s
|
||||
Just (Right (u, p)) -> Just $ render u p
|
||||
css <- forM (Map.toList style) $ \(mmedia, content) -> do
|
||||
let rendered = toLazyText $ content render
|
||||
x <- addStaticContent "css" "text/css; charset=utf-8"
|
||||
$ encodeUtf8 rendered
|
||||
return (mmedia,
|
||||
case x of
|
||||
Nothing -> Left $ preEscapedToMarkup rendered
|
||||
Just y -> Right $ either id (uncurry render) y)
|
||||
jsLoc <-
|
||||
case jscript of
|
||||
Nothing -> return Nothing
|
||||
Just s -> do
|
||||
x <- addStaticContent "js" "text/javascript; charset=utf-8"
|
||||
$ encodeUtf8 $ renderJavascriptUrl render s
|
||||
return $ renderLoc x
|
||||
|
||||
-- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing
|
||||
-- the asynchronous loader means your page doesn't have to wait for all the js to load
|
||||
let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
|
||||
regularScriptLoad = [hamlet|
|
||||
$newline never
|
||||
$forall s <- scripts
|
||||
^{mkScriptTag s}
|
||||
$maybe j <- jscript
|
||||
$maybe s <- jsLoc
|
||||
<script src="#{s}">
|
||||
$nothing
|
||||
<script>^{jelper j}
|
||||
|]
|
||||
|
||||
headAll = [hamlet|
|
||||
$newline never
|
||||
\^{head'}
|
||||
$forall s <- stylesheets
|
||||
^{mkLinkTag s}
|
||||
$forall s <- css
|
||||
$maybe t <- right $ snd s
|
||||
$maybe media <- fst s
|
||||
<link rel=stylesheet media=#{media} href=#{t}>
|
||||
$nothing
|
||||
<link rel=stylesheet href=#{t}>
|
||||
$maybe content <- left $ snd s
|
||||
$maybe media <- fst s
|
||||
<style media=#{media}>#{content}
|
||||
$nothing
|
||||
<style>#{content}
|
||||
$case jsLoader master
|
||||
$of BottomOfBody
|
||||
$of BottomOfHeadAsync asyncJsLoader
|
||||
^{asyncJsLoader asyncScripts mcomplete}
|
||||
$of BottomOfHeadBlocking
|
||||
^{regularScriptLoad}
|
||||
|]
|
||||
let bodyScript = [hamlet|
|
||||
$newline never
|
||||
^{body}
|
||||
^{regularScriptLoad}
|
||||
|]
|
||||
|
||||
return $ PageContent title headAll $
|
||||
case jsLoader master of
|
||||
BottomOfBody -> bodyScript
|
||||
_ -> body
|
||||
where
|
||||
renderLoc' render' (Local url) = render' url []
|
||||
renderLoc' _ (Remote s) = s
|
||||
|
||||
addAttr x (y, z) = x H.! H.customAttribute (H.textTag y) (H.toValue z)
|
||||
mkScriptTag (Script loc attrs) render' =
|
||||
foldl' addAttr H.script (("src", renderLoc' render' loc) : attrs) $ return ()
|
||||
mkLinkTag (Stylesheet loc attrs) render' =
|
||||
foldl' addAttr H.link
|
||||
( ("rel", "stylesheet")
|
||||
: ("href", renderLoc' render' loc)
|
||||
: attrs
|
||||
)
|
||||
|
||||
runUniqueList :: Eq x => UniqueList x -> [x]
|
||||
runUniqueList (UniqueList x) = nub $ x []
|
||||
|
||||
asyncHelper :: (url -> [x] -> Text)
|
||||
-> [Script (url)]
|
||||
-> Maybe (JavascriptUrl (url))
|
||||
-> Maybe Text
|
||||
-> (Maybe (HtmlUrl url), [Text])
|
||||
asyncHelper render scripts jscript jsLoc =
|
||||
(mcomplete, scripts'')
|
||||
where
|
||||
scripts' = map goScript scripts
|
||||
scripts'' =
|
||||
case jsLoc of
|
||||
Just s -> scripts' ++ [s]
|
||||
Nothing -> scripts'
|
||||
goScript (Script (Local url) _) = render url []
|
||||
goScript (Script (Remote s) _) = s
|
||||
mcomplete =
|
||||
case jsLoc of
|
||||
Just{} -> Nothing
|
||||
Nothing ->
|
||||
case jscript of
|
||||
Nothing -> Nothing
|
||||
Just j -> Just $ jelper j
|
||||
|
||||
jsToHtml :: Javascript -> Html
|
||||
jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
|
||||
|
||||
jelper :: JavascriptUrl url -> HtmlUrl url
|
||||
jelper = fmap jsToHtml
|
||||
|
||||
right :: Either a b -> Maybe b
|
||||
right (Right x) = Just x
|
||||
right _ = Nothing
|
||||
|
||||
left :: Either a b -> Maybe a
|
||||
left (Left x) = Just x
|
||||
left _ = Nothing
|
||||
|
||||
------------------------------------
|
||||
-- Formerly Yesod.Core.Content
|
||||
------------------------------------
|
||||
instance ToContent Css where
|
||||
toContent = toContent . renderCss
|
||||
instance ToContent Javascript where
|
||||
toContent = toContent . toLazyText . unJavascript
|
||||
instance HasContentType Css where
|
||||
getContentType _ = typeCss
|
||||
instance HasContentType Javascript where
|
||||
getContentType _ = typeJavascript
|
||||
instance ToTypedContent Css where
|
||||
toTypedContent = TypedContent typeCss . toContent
|
||||
instance ToTypedContent Javascript where
|
||||
toTypedContent = TypedContent typeJavascript . toContent
|
||||
|
||||
------------------------------------
|
||||
-- Formerly Yesod.Core.Widget
|
||||
------------------------------------
|
||||
instance render ~ RY site => ToWidget site (render -> Css) where
|
||||
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
|
||||
instance ToWidget site Css where
|
||||
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x
|
||||
instance render ~ RY site => ToWidget site (render -> Javascript) where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
|
||||
instance ToWidget site Javascript where
|
||||
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty
|
||||
instance render ~ RY site => ToWidgetMedia site (render -> Css) where
|
||||
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
|
||||
instance ToWidgetMedia site Css where
|
||||
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
|
||||
instance render ~ RY site => ToWidgetHead site (render -> Css) where
|
||||
toWidgetHead = toWidget
|
||||
instance render ~ RY site => ToWidgetHead site (render -> Javascript) where
|
||||
toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
|
||||
instance ToWidgetHead site Javascript where
|
||||
toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
|
||||
instance render ~ RY site => ToWidgetBody site (render -> Javascript) where
|
||||
toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
|
||||
instance ToWidgetBody site Javascript where
|
||||
toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
|
||||
instance ToWidgetHead site Html where
|
||||
toWidgetHead = toWidgetHead . const
|
||||
instance ToWidgetHead site Css where
|
||||
toWidgetHead = toWidget
|
||||
instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where
|
||||
toWidgetHead = toWidget
|
||||
instance ToWidgetHead site CssBuilder where
|
||||
toWidgetHead = toWidget
|
||||
|
||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
||||
-- set values.
|
||||
setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
|
||||
setTitleI msg = do
|
||||
mr <- getMessageRender
|
||||
setTitle $ toHtml $ mr msg
|
||||
|
||||
|
||||
-- | Sets a message in the user's session.
|
||||
--
|
||||
-- See 'getMessage'.
|
||||
setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
|
||||
=> msg -> m ()
|
||||
setMessageI msg = do
|
||||
mr <- getMessageRender
|
||||
setMessage $ toHtml $ mr msg
|
||||
|
||||
-- | Return a 403 permission denied page.
|
||||
permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m)
|
||||
=> msg
|
||||
-> m a
|
||||
permissionDeniedI msg = do
|
||||
mr <- getMessageRender
|
||||
permissionDenied $ mr msg
|
||||
|
||||
-- | Return a 400 invalid arguments page.
|
||||
invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
|
||||
invalidArgsI msg = do
|
||||
mr <- getMessageRender
|
||||
invalidArgs $ map mr msg
|
||||
|
||||
|
||||
getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)
|
||||
=> m (message -> Text)
|
||||
getMessageRender = do
|
||||
site <- getYesod
|
||||
l <- reqLangs `liftM` getRequest
|
||||
return $ renderMessage site l
|
||||
|
||||
-----------------------------
|
||||
-- originally from Yesod.Core
|
||||
-----------------------------
|
||||
-- | Return an 'Unauthorized' value, with the given i18n message.
|
||||
unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult
|
||||
unauthorizedI msg = do
|
||||
mr <- getMessageRender
|
||||
return $ Unauthorized $ mr msg
|
||||
|
||||
@ -30,7 +30,6 @@ library
|
||||
, text >= 0.7
|
||||
, template-haskell
|
||||
, path-pieces >= 0.1.2 && < 0.3
|
||||
, shakespeare >= 2.0
|
||||
, blaze-builder >= 0.2.1.4 && < 0.5
|
||||
, transformers >= 0.2.2
|
||||
, mtl
|
||||
|
||||
Loading…
Reference in New Issue
Block a user