haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Incomplete change: GWidget/GHandler->WidgetT/HandlerT

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-14 05:00:16 +02:00
parent 9503921d90
commit 553dff7bd2
11 changed files with 192 additions and 297 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
yesod-core/Yesod/Core.hs
View File

@ -78,7 +78,6 @@ import Data.Text (Text)
import Yesod.Core.Widget import Yesod.Core.Widget
import Yesod.Core.Json import Yesod.Core.Json
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Class.MonadLift
import Text.Shakespeare.I18N import Text.Shakespeare.I18N
import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822) import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)

4
yesod-core/Yesod/Core/Class/Breadcrumbs.hs
View File

@ -11,11 +11,11 @@ import Data.Text (Text)
class YesodBreadcrumbs site where class YesodBreadcrumbs site where
-- | Returns the title and the parent resource, if available. If you return -- | Returns the title and the parent resource, if available. If you return
-- a 'Nothing', then this is considered a top-level page. -- a 'Nothing', then this is considered a top-level page.
breadcrumb :: Route site -> GHandler site (Text , Maybe (Route site)) breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site))
-- | Gets the title of the current page and the hierarchy of parent pages, -- | Gets the title of the current page and the hierarchy of parent pages,
-- along with their respective titles. -- along with their respective titles.
breadcrumbs :: YesodBreadcrumbs site => GHandler site (Text, [(Route site, Text)]) breadcrumbs :: YesodBreadcrumbs site => HandlerT site IO (Text, [(Route site, Text)])
breadcrumbs = do breadcrumbs = do
x <- getCurrentRoute x <- getCurrentRoute
case x of case x of

49
yesod-core/Yesod/Core/Class/Handler.hs
View File

@ -1,49 +1,36 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Class.Handler where module Yesod.Core.Class.Handler where
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Types.Orphan ()
import Yesod.Core.Class.MonadLift (lift)
import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Trans.Class (MonadTrans)
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
import Data.IORef.Lifted (atomicModifyIORef) import Data.IORef.Lifted (atomicModifyIORef)
import Control.Exception.Lifted (throwIO) import Control.Exception.Lifted (throwIO)
import Control.Monad.Base
import Data.Monoid (mempty)
class Monad m => HandlerReader m where class Monad m => HandlerReader m where
type HandlerSite m type HandlerSite m
type HandlerMaster m
askYesodRequest :: m YesodRequest askYesodRequest :: m YesodRequest
askHandlerEnv :: m (RunHandlerEnv (HandlerSite m)) askHandlerEnv :: m (RunHandlerEnv (HandlerSite m))
askHandlerEnvMaster :: m (RunHandlerEnv (HandlerMaster m))
instance HandlerReader (GHandler site) where instance Monad m => HandlerReader (HandlerT site m) where
type HandlerSite (GHandler site) = site
type HandlerMaster (GHandler site) = site
askYesodRequest = GHandler $ return . handlerRequest
askHandlerEnv = GHandler $ return . handlerEnv
askHandlerEnvMaster = GHandler $ return . handlerEnv
instance HandlerReader m => HandlerReader (HandlerT site m) where
type HandlerSite (HandlerT site m) = site type HandlerSite (HandlerT site m) = site
type HandlerMaster (HandlerT site m) = HandlerMaster m
askYesodRequest = HandlerT $ return . handlerRequest askYesodRequest = HandlerT $ return . handlerRequest
askHandlerEnv = HandlerT $ return . handlerEnv askHandlerEnv = HandlerT $ return . handlerEnv
askHandlerEnvMaster = lift askHandlerEnvMaster
instance HandlerReader (GWidget site) where instance Monad m => HandlerReader (WidgetT site m) where
type HandlerSite (GWidget site) = site type HandlerSite (WidgetT site m) = site
type HandlerMaster (GWidget site) = site
askYesodRequest = lift askYesodRequest askYesodRequest = WidgetT $ fmap (, mempty) $ askYesodRequest
askHandlerEnv = lift askHandlerEnv askHandlerEnv = WidgetT $ fmap (, mempty) $ askHandlerEnv
askHandlerEnvMaster = lift askHandlerEnvMaster
class HandlerReader m => HandlerState m where class HandlerReader m => HandlerState m where
stateGHState :: (GHState -> (a, GHState)) -> m a stateGHState :: (GHState -> (a, GHState)) -> m a
@ -54,26 +41,20 @@ class HandlerReader m => HandlerState m where
putGHState :: GHState -> m () putGHState :: GHState -> m ()
putGHState s = stateGHState $ const ((), s) putGHState s = stateGHState $ const ((), s)
instance HandlerState (GHandler site) where instance MonadBase IO m => HandlerState (HandlerT site m) where
stateGHState f = stateGHState f =
GHandler $ flip atomicModifyIORef f' . handlerState HandlerT $ flip atomicModifyIORef f' . handlerState
where where
f' z = let (x, y) = f z in (y, x) f' z = let (x, y) = f z in (y, x)
instance HandlerState (GWidget site) where instance MonadBase IO m => HandlerState (WidgetT site m) where
stateGHState = lift . stateGHState stateGHState = WidgetT . fmap (, mempty) . stateGHState
instance HandlerState m => HandlerState (HandlerT site m) where
stateGHState = lift . stateGHState
class HandlerReader m => HandlerError m where class HandlerReader m => HandlerError m where
handlerError :: HandlerContents -> m a handlerError :: HandlerContents -> m a
instance HandlerError (GHandler site) where instance MonadBase IO m => HandlerError (HandlerT site m) where
handlerError = throwIO handlerError = throwIO
instance HandlerError (GWidget site) where instance MonadBase IO m => HandlerError (WidgetT site m) where
handlerError = lift . handlerError handlerError = throwIO
instance HandlerError m => HandlerError (HandlerT site m) where
handlerError = lift . handlerError

15
yesod-core/Yesod/Core/Class/MonadLift.hs
View File

@ -1,15 +0,0 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
module Yesod.Core.Class.MonadLift (MonadLift (..)) where
import Control.Monad.Trans.Class
-- | The standard @MonadTrans@ class only allows lifting for monad
-- transformers. While @GHandler@ and @GWidget@ should allow lifting, their
-- types do not express that they actually are transformers. This replacement
-- class accounts for this.
class MonadLift base m | m -> base where
lift :: base a -> m a
instance (Monad m, MonadTrans t) => MonadLift m (t m) where
lift = Control.Monad.Trans.Class.lift

96
yesod-core/Yesod/Core/Class/Yesod.hs
View File

@ -58,11 +58,10 @@ import Web.Cookie (SetCookie (..))
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Internal.Session import Yesod.Core.Internal.Session
import Yesod.Core.Widget import Yesod.Core.Widget
import Yesod.Core.Class.MonadLift (lift)
-- | Define settings for a Yesod applications. All methods have intelligent -- | Define settings for a Yesod applications. All methods have intelligent
-- defaults, and therefore no implementation is required. -- defaults, and therefore no implementation is required.
class RenderRoute a => Yesod a where class RenderRoute site => Yesod site where
-- | An absolute URL to the root of the application. Do not include -- | An absolute URL to the root of the application. Do not include
-- trailing slash. -- trailing slash.
-- --
@ -76,36 +75,34 @@ class RenderRoute a => Yesod a where
-- --
-- If this is not true, you should override with a different -- If this is not true, you should override with a different
-- implementation. -- implementation.
approot :: Approot a approot :: Approot site
approot = ApprootRelative approot = ApprootRelative
-- | Output error response pages. -- | Output error response pages.
errorHandler :: ErrorResponse -> GHandler a TypedContent errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
errorHandler = defaultErrorHandler errorHandler = defaultErrorHandler
-- | Applies some form of layout to the contents of a page. -- | Applies some form of layout to the contents of a page.
defaultLayout :: GWidget a () -> GHandler a RepHtml defaultLayout :: WidgetT site IO () -> HandlerT site IO RepHtml
defaultLayout w = do defaultLayout w = do
p <- widgetToPageContent w p <- widgetToPageContent w
mmsg <- getMessage mmsg <- getMessage
hamletToRepHtml [hamlet| hamletToRepHtml [hamlet|
$newline never $doctype 5
$doctype 5 <html>
<head>
<html> <title>#{pageTitle p}
<head> ^{pageHead p}
<title>#{pageTitle p} <body>
^{pageHead p} $maybe msg <- mmsg
<body> <p .message>#{msg}
$maybe msg <- mmsg ^{pageBody p}
<p .message>#{msg} |]
^{pageBody p}
|]
-- | Override the rendering function for a particular URL. One use case for -- | Override the rendering function for a particular URL. One use case for
-- this is to offload static hosting to a different domain name to avoid -- this is to offload static hosting to a different domain name to avoid
-- sending cookies. -- sending cookies.
urlRenderOverride :: a -> Route a -> Maybe Builder urlRenderOverride :: site -> Route site -> Maybe Builder
urlRenderOverride _ _ = Nothing urlRenderOverride _ _ = Nothing
-- | Determine if a request is authorized or not. -- | Determine if a request is authorized or not.
@ -113,9 +110,9 @@ $doctype 5
-- Return 'Authorized' if the request is authorized, -- Return 'Authorized' if the request is authorized,
-- 'Unauthorized' a message if unauthorized. -- 'Unauthorized' a message if unauthorized.
-- If authentication is required, return 'AuthenticationRequired'. -- If authentication is required, return 'AuthenticationRequired'.
isAuthorized :: Route a isAuthorized :: Route site
-> Bool -- ^ is this a write request? -> Bool -- ^ is this a write request?
-> GHandler a AuthResult -> HandlerT site IO AuthResult
isAuthorized _ _ = return Authorized isAuthorized _ _ = return Authorized
-- | Determines whether the current request is a write request. By default, -- | Determines whether the current request is a write request. By default,
@ -125,7 +122,7 @@ $doctype 5
-- --
-- This function is used to determine if a request is authorized; see -- This function is used to determine if a request is authorized; see
-- 'isAuthorized'. -- 'isAuthorized'.
isWriteRequest :: Route a -> GHandler a Bool isWriteRequest :: Route site -> HandlerT site IO Bool
isWriteRequest _ = do isWriteRequest _ = do
wai <- waiRequest wai <- waiRequest
return $ W.requestMethod wai `notElem` return $ W.requestMethod wai `notElem`
@ -135,7 +132,7 @@ $doctype 5
-- --
-- Used in particular by 'isAuthorized', but library users can do whatever -- Used in particular by 'isAuthorized', but library users can do whatever
-- they want with it. -- they want with it.
authRoute :: a -> Maybe (Route a) authRoute :: site -> Maybe (Route site)
authRoute _ = Nothing authRoute _ = Nothing
-- | A function used to clean up path segments. It returns 'Right' with a -- | A function used to clean up path segments. It returns 'Right' with a
@ -148,7 +145,7 @@ $doctype 5
-- --
-- Note that versions of Yesod prior to 0.7 used a different set of rules -- Note that versions of Yesod prior to 0.7 used a different set of rules
-- involing trailing slashes. -- involing trailing slashes.
cleanPath :: a -> [Text] -> Either [Text] [Text] cleanPath :: site -> [Text] -> Either [Text] [Text]
cleanPath _ s = cleanPath _ s =
if corrected == s if corrected == s
then Right $ map dropDash s then Right $ map dropDash s
@ -162,7 +159,7 @@ $doctype 5
-- | Builds an absolute URL by concatenating the application root with the -- | Builds an absolute URL by concatenating the application root with the
-- pieces of a path and a query string, if any. -- pieces of a path and a query string, if any.
-- Note that the pieces of the path have been previously cleaned up by 'cleanPath'. -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.
joinPath :: a joinPath :: site
-> T.Text -- ^ application root -> T.Text -- ^ application root
-> [T.Text] -- ^ path pieces -> [T.Text] -- ^ path pieces
-> [(T.Text, T.Text)] -- ^ query string -> [(T.Text, T.Text)] -- ^ query string
@ -191,7 +188,7 @@ $doctype 5
addStaticContent :: Text -- ^ filename extension addStaticContent :: Text -- ^ filename extension
-> Text -- ^ mime-type -> Text -- ^ mime-type
-> L.ByteString -- ^ content -> L.ByteString -- ^ content
-> GHandler a (Maybe (Either Text (Route a, [(Text, Text)]))) -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
addStaticContent _ _ _ = return Nothing addStaticContent _ _ _ = return Nothing
{- Temporarily disabled until we have a better interface. {- Temporarily disabled until we have a better interface.
@ -208,17 +205,17 @@ $doctype 5
-- | Maximum allowed length of the request body, in bytes. -- | Maximum allowed length of the request body, in bytes.
-- --
-- Default: 2 megabytes. -- Default: 2 megabytes.
maximumContentLength :: a -> Maybe (Route a) -> Word64 maximumContentLength :: site -> Maybe (Route site) -> Word64
maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
-- | Returns a @Logger@ to use for log messages. -- | Returns a @Logger@ to use for log messages.
-- --
-- Default: Sends to stdout and automatically flushes on each write. -- Default: Sends to stdout and automatically flushes on each write.
getLogger :: a -> IO Logger getLogger :: site -> IO Logger
getLogger _ = mkLogger True stdout getLogger _ = mkLogger True stdout
-- | Send a message to the @Logger@ provided by @getLogger@. -- | Send a message to the @Logger@ provided by @getLogger@.
messageLoggerSource :: a messageLoggerSource :: site
-> Logger -> Logger
-> Loc -- ^ position in source code -> Loc -- ^ position in source code
-> LogSource -> LogSource
@ -232,11 +229,11 @@ $doctype 5
-- | The logging level in place for this application. Any messages below -- | The logging level in place for this application. Any messages below
-- this level will simply be ignored. -- this level will simply be ignored.
logLevel :: a -> LogLevel logLevel :: site -> LogLevel
logLevel _ = LevelInfo logLevel _ = LevelInfo
-- | GZIP settings. -- | GZIP settings.
gzipSettings :: a -> GzipSettings gzipSettings :: site -> GzipSettings
gzipSettings _ = def gzipSettings _ = def
-- | Where to Load sripts from. We recommend the default value, -- | Where to Load sripts from. We recommend the default value,
@ -245,13 +242,13 @@ $doctype 5
-- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js
-- --
-- Or write your own async js loader: see 'loadJsYepnope' -- Or write your own async js loader: see 'loadJsYepnope'
jsLoader :: a -> ScriptLoadPosition a jsLoader :: site -> ScriptLoadPosition site
jsLoader _ = BottomOfBody jsLoader _ = BottomOfBody
-- | Create a session backend. Returning `Nothing' disables sessions. -- | Create a session backend. Returning `Nothing' disables sessions.
-- --
-- Default: Uses clientsession with a 2 hour timeout. -- Default: Uses clientsession with a 2 hour timeout.
makeSessionBackend :: a -> IO (Maybe SessionBackend) makeSessionBackend :: site -> IO (Maybe SessionBackend)
makeSessionBackend _ = fmap Just defaultClientSessionBackend makeSessionBackend _ = fmap Just defaultClientSessionBackend
-- | How to store uploaded files. -- | How to store uploaded files.
@ -259,7 +256,7 @@ $doctype 5
-- Default: When the request body is greater than 50kb, store in a temp -- Default: When the request body is greater than 50kb, store in a temp
-- file. For chunked request bodies, store in a temp file. Otherwise, store -- file. For chunked request bodies, store in a temp file. Otherwise, store
-- in memory. -- in memory.
fileUpload :: a -> W.RequestBodyLength -> FileUpload fileUpload :: site -> W.RequestBodyLength -> FileUpload
fileUpload _ (W.KnownLength size) fileUpload _ (W.KnownLength size)
| size <= 50000 = FileUploadMemory lbsBackEnd | size <= 50000 = FileUploadMemory lbsBackEnd
fileUpload _ _ = FileUploadDisk tempFileBackEnd fileUpload _ _ = FileUploadDisk tempFileBackEnd
@ -267,8 +264,8 @@ $doctype 5
-- | Should we log the given log source/level combination. -- | Should we log the given log source/level combination.
-- --
-- Default: Logs everything at or above 'logLevel' -- Default: Logs everything at or above 'logLevel'
shouldLog :: a -> LogSource -> LogLevel -> Bool shouldLog :: site -> LogSource -> LogLevel -> Bool
shouldLog a _ level = level >= logLevel a shouldLog site _ level = level >= logLevel site
-- | A Yesod middleware, which will wrap every handler function. This -- | A Yesod middleware, which will wrap every handler function. This
-- allows you to run code before and after a normal handler. -- allows you to run code before and after a normal handler.
@ -277,7 +274,7 @@ $doctype 5
-- performs authorization checks. -- performs authorization checks.
-- --
-- Since: 1.1.6 -- Since: 1.1.6
yesodMiddleware :: GHandler a res -> GHandler a res yesodMiddleware :: HandlerT site IO res -> HandlerT site IO res
yesodMiddleware handler = do yesodMiddleware handler = do
setHeader "Vary" "Accept, Accept-Language" setHeader "Vary" "Accept, Accept-Language"
route <- getCurrentRoute route <- getCurrentRoute
@ -301,11 +298,11 @@ $doctype 5
-- | Convert a widget to a 'PageContent'. -- | Convert a widget to a 'PageContent'.
widgetToPageContent :: (Eq (Route site), Yesod site) widgetToPageContent :: (Eq (Route site), Yesod site)
=> GWidget site () => WidgetT site IO ()
-> GHandler site (PageContent (Route site)) -> HandlerT site IO (PageContent (Route site))
widgetToPageContent w = do widgetToPageContent w = do
master <- getYesod master <- getYesod
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unWidgetT w
let title = maybe mempty unTitle mTitle let title = maybe mempty unTitle mTitle
scripts = runUniqueList scripts' scripts = runUniqueList scripts'
stylesheets = runUniqueList stylesheets' stylesheets = runUniqueList stylesheets'
@ -396,10 +393,10 @@ $newline never
runUniqueList (UniqueList x) = nub $ x [] runUniqueList (UniqueList x) = nub $ x []
-- | The default error handler for 'errorHandler'. -- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod site => ErrorResponse -> GHandler site TypedContent defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent
defaultErrorHandler NotFound = selectRep $ do defaultErrorHandler NotFound = selectRep $ do
provideRep $ defaultLayout $ do provideRep $ defaultLayout $ do
r <- lift waiRequest r <- waiRequest
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
setTitle "Not Found" setTitle "Not Found"
toWidget [hamlet| toWidget [hamlet|
@ -560,20 +557,3 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
where where
line = show . fst . loc_start line = show . fst . loc_start
char = show . snd . loc_start char = show . snd . loc_start
class (MonadBaseControl IO m, HandlerState m, HandlerError m, MonadResource m, Yesod (HandlerMaster m)) => MonadHandler m where
liftHandler :: GHandler (HandlerSite m) a -> m a
liftHandler (GHandler f) = do
hd <- askHandlerData
liftResourceT $ f hd
liftHandlerMaster :: GHandler (HandlerMaster m) a -> m a
askHandlerData :: m (HandlerData (HandlerSite m))
instance Yesod site => MonadHandler (GHandler site) where
liftHandler = id
liftHandlerMaster = id
askHandlerData = GHandler return
instance MonadHandler m => MonadHandler (HandlerT site m) where
liftHandlerMaster = lift . liftHandlerMaster
askHandlerData = HandlerT return

26
yesod-core/Yesod/Core/Handler.hs
View File

@ -21,8 +21,7 @@
--------------------------------------------------------- ---------------------------------------------------------
module Yesod.Core.Handler module Yesod.Core.Handler
( -- * Handler monad ( -- * Handler monad
GHandler HandlerT
, HandlerT
-- ** Read information from handler -- ** Read information from handler
, getYesod , getYesod
, getUrlRender , getUrlRender
@ -167,7 +166,6 @@ import Data.Maybe (listToMaybe)
import Data.Typeable (Typeable, typeOf) import Data.Typeable (Typeable, typeOf)
import Yesod.Core.Class.Handler import Yesod.Core.Class.Handler
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Types.Orphan ()
import Yesod.Routes.Class (Route) import Yesod.Routes.Class (Route)
get :: HandlerState m => m GHState get :: HandlerState m => m GHState
@ -251,10 +249,10 @@ getUrlRenderParams = rheRender `liftM` askHandlerEnv
getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSite m))) getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSite m)))
getCurrentRoute = rheRoute `liftM` askHandlerEnv getCurrentRoute = rheRoute `liftM` askHandlerEnv
-- | Returns a function that runs 'GHandler' actions inside @IO@. -- | Returns a function that runs 'HandlerT' actions inside @IO@.
-- --
-- Sometimes you want to run an inner 'GHandler' action outside -- Sometimes you want to run an inner 'HandlerT' action outside
-- the control flow of an HTTP request (on the outer 'GHandler' -- the control flow of an HTTP request (on the outer 'HandlerT'
-- action). For example, you may want to spawn a new thread: -- action). For example, you may want to spawn a new thread:
-- --
-- @ -- @
@ -287,9 +285,9 @@ getCurrentRoute = rheRoute `liftM` askHandlerEnv
-- This allows the inner 'GHandler' to outlive the outer -- This allows the inner 'GHandler' to outlive the outer
-- 'GHandler' (e.g., on the @forkIO@ example above, a response -- 'GHandler' (e.g., on the @forkIO@ example above, a response
-- may be sent to the client without killing the new thread). -- may be sent to the client without killing the new thread).
handlerToIO :: MonadIO m => GHandler site (GHandler site a -> m a) handlerToIO :: (MonadIO m1, MonadIO m2) => HandlerT site m1 (HandlerT site IO a -> m2 a)
handlerToIO = handlerToIO =
GHandler $ \oldHandlerData -> do HandlerT $ \oldHandlerData -> do
-- Let go of the request body, cache and response headers. -- Let go of the request body, cache and response headers.
let oldReq = handlerRequest oldHandlerData let oldReq = handlerRequest oldHandlerData
oldWaiReq = reqWaiRequest oldReq oldWaiReq = reqWaiRequest oldReq
@ -311,7 +309,7 @@ handlerToIO =
, ghsHeaders = mempty } , ghsHeaders = mempty }
-- Return GHandler running function. -- Return GHandler running function.
return $ \(GHandler f) -> liftIO $ do return $ \(HandlerT f) -> liftIO $ do
-- The state IORef needs to be created here, otherwise it -- The state IORef needs to be created here, otherwise it
-- will be shared by different invocations of this function. -- will be shared by different invocations of this function.
newStateIORef <- I.newIORef newState newStateIORef <- I.newIORef newState
@ -417,7 +415,7 @@ setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
-- | Sets a message in the user's session. -- | Sets a message in the user's session.
-- --
-- See 'getMessage'. -- See 'getMessage'.
setMessageI :: (HandlerState m, RenderMessage (HandlerMaster m) msg) setMessageI :: (HandlerState m, RenderMessage (HandlerSite m) msg)
=> msg -> m () => msg -> m ()
setMessageI msg = do setMessageI msg = do
mr <- getMessageRender mr <- getMessageRender
@ -490,7 +488,7 @@ permissionDenied :: HandlerError m => Text -> m a
permissionDenied = hcError . PermissionDenied permissionDenied = hcError . PermissionDenied
-- | Return a 403 permission denied page. -- | Return a 403 permission denied page.
permissionDeniedI :: (RenderMessage (HandlerMaster m) msg, HandlerError m) permissionDeniedI :: (RenderMessage (HandlerSite m) msg, HandlerError m)
=> msg => msg
-> m a -> m a
permissionDeniedI msg = do permissionDeniedI msg = do
@ -502,7 +500,7 @@ invalidArgs :: HandlerError m => [Text] -> m a
invalidArgs = hcError . InvalidArgs invalidArgs = hcError . InvalidArgs
-- | Return a 400 invalid arguments page. -- | Return a 400 invalid arguments page.
invalidArgsI :: (HandlerError m, RenderMessage (HandlerMaster m) msg) => [msg] -> m a invalidArgsI :: (HandlerError m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
invalidArgsI msg = do invalidArgsI msg = do
mr <- getMessageRender mr <- getMessageRender
invalidArgs $ map mr msg invalidArgs $ map mr msg
@ -693,10 +691,10 @@ giveUrlRenderer f = do
waiRequest :: HandlerReader m => m W.Request waiRequest :: HandlerReader m => m W.Request
waiRequest = reqWaiRequest `liftM` getRequest waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (HandlerReader m, RenderMessage (HandlerMaster m) message) getMessageRender :: (HandlerReader m, RenderMessage (HandlerSite m) message)
=> m (message -> Text) => m (message -> Text)
getMessageRender = do getMessageRender = do
env <- askHandlerEnvMaster env <- askHandlerEnv
l <- reqLangs `liftM` getRequest l <- reqLangs `liftM` getRequest
return $ renderMessage (rheSite env) l return $ renderMessage (rheSite env) l

45
yesod-core/Yesod/Core/Json.hs
View File

@ -19,11 +19,11 @@ module Yesod.Core.Json
, acceptsJson , acceptsJson
) where ) where
import Yesod.Core.Handler (GHandler, waiRequest, invalidArgs, redirect, selectRep, provideRep) import Yesod.Core.Handler (HandlerT, waiRequest, invalidArgs, redirect, selectRep, provideRep)
import Yesod.Core.Class.MonadLift (lift)
import Yesod.Core.Content (TypedContent) import Yesod.Core.Content (TypedContent)
import Yesod.Core.Class.Yesod (defaultLayout, Yesod) import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
import Yesod.Core.Widget (GWidget) import Yesod.Core.Class.Handler
import Yesod.Core.Widget (WidgetT)
import Yesod.Routes.Class import Yesod.Routes.Class
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (join) import Control.Monad (join)
@ -38,6 +38,9 @@ import Network.Wai (requestBody, requestHeaders)
import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Parse (parseHttpAccept)
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Control.Monad.Trans.Class (lift)
import Control.Monad (liftM)
import Control.Monad.Trans.Resource (liftResourceT)
-- | Provide both an HTML and JSON representation for a piece of -- | Provide both an HTML and JSON representation for a piece of
-- data, using the default layout for the HTML output -- data, using the default layout for the HTML output
@ -45,9 +48,9 @@ import Data.Maybe (listToMaybe)
-- --
-- /Since: 0.3.0/ -- /Since: 0.3.0/
defaultLayoutJson :: (Yesod site, J.ToJSON a) defaultLayoutJson :: (Yesod site, J.ToJSON a)
=> GWidget site () -- ^ HTML => WidgetT site m () -- ^ HTML
-> GHandler site a -- ^ JSON -> HandlerT site m a -- ^ JSON
-> GHandler site TypedContent -> HandlerT site m TypedContent
defaultLayoutJson w json = selectRep $ do defaultLayoutJson w json = selectRep $ do
provideRep $ defaultLayout w provideRep $ defaultLayout w
provideRep $ fmap J.toJSON json provideRep $ fmap J.toJSON json
@ -56,7 +59,7 @@ defaultLayoutJson w json = selectRep $ do
-- support conversion to JSON via 'J.ToJSON'. -- support conversion to JSON via 'J.ToJSON'.
-- --
-- /Since: 0.3.0/ -- /Since: 0.3.0/
jsonToRepJson :: J.ToJSON a => a -> GHandler site J.Value jsonToRepJson :: J.ToJSON a => a -> HandlerT site m J.Value
jsonToRepJson = return . J.toJSON jsonToRepJson = return . J.toJSON
-- | Parse the request body to a data type as a JSON value. The -- | Parse the request body to a data type as a JSON value. The
@ -65,12 +68,11 @@ jsonToRepJson = return . J.toJSON
-- 'J.Value'@. -- 'J.Value'@.
-- --
-- /Since: 0.3.0/ -- /Since: 0.3.0/
parseJsonBody :: J.FromJSON a => GHandler site (J.Result a) parseJsonBody :: (MonadResource m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do parseJsonBody = do
req <- waiRequest req <- waiRequest
eValue <- lift eValue <- runExceptionT
$ runExceptionT $ transPipe liftResourceT (requestBody req)
$ transPipe lift (requestBody req)
$$ sinkParser JP.value' $$ sinkParser JP.value'
return $ case eValue of return $ case eValue of
Left e -> J.Error $ show e Left e -> J.Error $ show e
@ -78,7 +80,7 @@ parseJsonBody = do
-- | Same as 'parseJsonBody', but return an invalid args response on a parse -- | Same as 'parseJsonBody', but return an invalid args response on a parse
-- error. -- error.
parseJsonBody_ :: J.FromJSON a => GHandler site a parseJsonBody_ :: (HandlerError m, J.FromJSON a, MonadResource m) => m a
parseJsonBody_ = do parseJsonBody_ = do
ra <- parseJsonBody ra <- parseJsonBody
case ra of case ra of
@ -96,20 +98,21 @@ array = J.Array . V.fromList . map J.toJSON
-- @application\/json@ (e.g. AJAX, see 'acceptsJSON'). -- @application\/json@ (e.g. AJAX, see 'acceptsJSON').
-- --
-- 2. 3xx otherwise, following the PRG pattern. -- 2. 3xx otherwise, following the PRG pattern.
jsonOrRedirect :: (Yesod site, J.ToJSON a) jsonOrRedirect :: HandlerError m
=> Route site -- ^ Redirect target => J.ToJSON a
=> Route (HandlerSite m) -- ^ Redirect target
-> a -- ^ Data to send via JSON -> a -- ^ Data to send via JSON
-> GHandler site J.Value -> m J.Value
jsonOrRedirect r j = do jsonOrRedirect r j = do
q <- acceptsJson q <- acceptsJson
if q then jsonToRepJson (J.toJSON j) if q then return (J.toJSON j)
else redirect r else redirect r
-- | Returns @True@ if the client prefers @application\/json@ as -- | Returns @True@ if the client prefers @application\/json@ as
-- indicated by the @Accept@ HTTP header. -- indicated by the @Accept@ HTTP header.
acceptsJson :: Yesod site => GHandler site Bool acceptsJson :: HandlerReader m => m Bool
acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';')) acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
. join . join
. fmap (listToMaybe . parseHttpAccept) . liftM (listToMaybe . parseHttpAccept)
. lookup "Accept" . requestHeaders . lookup "Accept" . requestHeaders)
<$> waiRequest `liftM` waiRequest

146
yesod-core/Yesod/Core/Types.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
@ -54,7 +55,7 @@ import Text.Hamlet (HtmlUrl)
import Text.Julius (JavascriptUrl) import Text.Julius (JavascriptUrl)
import Web.Cookie (SetCookie) import Web.Cookie (SetCookie)
import Yesod.Core.Internal.Util (getTime, putTime) import Yesod.Core.Internal.Util (getTime, putTime)
import Yesod.Core.Class.MonadLift (MonadLift (..)) import Control.Monad.Trans.Class
import Yesod.Routes.Class (RenderRoute (..)) import Yesod.Routes.Class (RenderRoute (..))
-- Sessions -- Sessions
@ -192,23 +193,10 @@ data YesodRunnerEnv site = YesodRunnerEnv
-- | A generic handler monad, which can have a different subsite and master -- | A generic handler monad, which can have a different subsite and master
-- site. We define a newtype for better error message. -- site. We define a newtype for better error message.
newtype GHandler site a = GHandler
{ unGHandler :: HandlerData site -> ResourceT IO a
}
newtype HandlerT site m a = HandlerT newtype HandlerT site m a = HandlerT
{ unHandlerT :: HandlerData site -> m a { unHandlerT :: HandlerData site -> ResourceT m a
} }
instance Monad m => Monad (HandlerT sub m) where
return = HandlerT . const . return
HandlerT f >>= g = HandlerT $ \hd -> f hd >>= \x -> unHandlerT (g x) hd
instance Monad m => Functor (HandlerT sub m) where
fmap = liftM
instance Monad m => Applicative (HandlerT sub m) where
pure = return
(<*>) = ap
data GHState = GHState data GHState = GHState
{ ghsSession :: SessionMap { ghsSession :: SessionMap
, ghsRBC :: Maybe RequestBodyContents , ghsRBC :: Maybe RequestBodyContents
@ -219,17 +207,17 @@ data GHState = GHState
-- | An extension of the basic WAI 'W.Application' datatype to provide extra -- | An extension of the basic WAI 'W.Application' datatype to provide extra
-- features needed by Yesod. Users should never need to use this directly, as -- features needed by Yesod. Users should never need to use this directly, as
-- the 'GHandler' monad and template haskell code should hide it away. -- the 'HandlerT' monad and template haskell code should hide it away.
type YesodApp = YesodRequest -> ResourceT IO YesodResponse type YesodApp = YesodRequest -> ResourceT IO YesodResponse
-- | A generic widget, allowing specification of both the subsite and master -- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. While this is simply a @WriterT@, we define a newtype for -- site datatypes. While this is simply a @WriterT@, we define a newtype for
-- better error messages. -- better error messages.
newtype GWidget site a = GWidget -- FIXME change to WidgetT? newtype WidgetT site m a = WidgetT
{ unGWidget :: GHandler site (a, GWData (Route site)) { unWidgetT :: HandlerT site m (a, GWData (Route site))
} }
instance (a ~ ()) => Monoid (GWidget site a) where instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
mempty = return () mempty = return ()
mappend x y = x >> y mappend x y = x >> y
@ -344,62 +332,56 @@ instance Show HandlerContents where
show _ = "Cannot show a HandlerContents" show _ = "Cannot show a HandlerContents"
instance Exception HandlerContents instance Exception HandlerContents
-- Instances for GWidget -- Instances for WidgetT
instance Functor (GWidget site) where instance Monad m => Functor (WidgetT site m) where
fmap f (GWidget x) = GWidget (fmap (first f) x) fmap = liftM
instance Applicative (GWidget site) where instance Monad m => Applicative (WidgetT site m) where
pure a = GWidget $ pure (a, mempty) pure = return
GWidget f <*> GWidget v = (<*>) = ap
GWidget $ k <$> f <*> v instance Monad m => Monad (WidgetT site m) where
where return a = WidgetT $ pure (a, mempty)
k (a, wa) (b, wb) = (a b, wa `mappend` wb) WidgetT x >>= f = WidgetT $ do
instance Monad (GWidget site) where
return = pure
GWidget x >>= f = GWidget $ do
(a, wa) <- x (a, wa) <- x
(b, wb) <- unGWidget (f a) (b, wb) <- unWidgetT (f a)
return (b, wa `mappend` wb) return (b, wa `mappend` wb)
instance MonadIO (GWidget site) where instance MonadIO m => MonadIO (WidgetT site m) where
liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO liftIO = lift . liftIO
instance MonadBase IO (GWidget site) where instance MonadBase b m => MonadBase b (WidgetT site m) where
liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase liftBase = WidgetT . fmap (\a -> (a, mempty)) . liftBase
instance MonadBaseControl IO (GWidget site) where instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
data StM (GWidget site) a = data StM (WidgetT site m) a =
StW (StM (GHandler site) (a, GWData (Route site))) StW (StM (HandlerT site m) (a, GWData (Route site)))
liftBaseWith f = GWidget $ liftBaseWith $ \runInBase -> liftBaseWith f = WidgetT $ liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty)) liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . unGWidget) (f $ liftM StW . runInBase . unWidgetT)
restoreM (StW base) = GWidget $ restoreM base restoreM (StW base) = WidgetT $ restoreM base
instance MonadUnsafeIO (GWidget site) where instance MonadTrans (WidgetT site) where
unsafeLiftIO = liftIO lift = WidgetT . fmap (, mempty) . lift
instance MonadThrow (GWidget site) where instance MonadThrow m => MonadThrow (WidgetT site m) where
monadThrow = liftIO . throwIO monadThrow = lift . monadThrow
instance MonadResource (GWidget site) where instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where
liftResourceT = lift . liftResourceT liftResourceT = WidgetT . fmap (, mempty) . liftResourceT
instance MonadLogger (GWidget site) where instance MonadIO m => MonadLogger (WidgetT site m) where
monadLoggerLog a b c = lift . monadLoggerLog a b c monadLoggerLog a b c d = WidgetT $ fmap (, mempty) $ monadLoggerLog a b c d
instance MonadLift (GHandler site) (GWidget site) where instance MonadTrans (HandlerT site) where
lift = GWidget . fmap (\x -> (x, mempty)) lift = HandlerT . const . lift
instance MonadLift (ResourceT IO) (GHandler site) where -- Instances for HandlerT
lift = GHandler . const instance Monad m => Functor (HandlerT site m) where
fmap = liftM
-- Instances for GHandler instance Monad m => Applicative (HandlerT site m) where
instance Functor (GHandler site) where pure = return
fmap f (GHandler x) = GHandler $ \r -> fmap f (x r) (<*>) = ap
instance Applicative (GHandler site) where instance Monad m => Monad (HandlerT site m) where
pure = GHandler . const . pure return = HandlerT . const . return
GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r
instance Monad (GHandler site) where instance MonadIO m => MonadIO (HandlerT site m) where
return = pure liftIO = lift . liftIO
GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r instance MonadBase b m => MonadBase b (HandlerT site m) where
instance MonadIO (GHandler site) where liftBase = lift . liftBase
liftIO = GHandler . const . lift
instance MonadBase IO (GHandler site) where
liftBase = GHandler . const . lift
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s -- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
-- @fork@ function is incompatible with the underlying @ResourceT@ system. -- @fork@ function is incompatible with the underlying @ResourceT@ system.
-- Instead, if you must fork a separate thread, you should use -- Instead, if you must fork a separate thread, you should use
@ -408,26 +390,24 @@ instance MonadBase IO (GHandler site) where
-- Using fork usually leads to an exception that says -- Using fork usually leads to an exception that says
-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed -- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
-- after cleanup. Please contact the maintainers.\" -- after cleanup. Please contact the maintainers.\"
instance MonadBaseControl IO (GHandler site) where instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
data StM (GHandler site) a = StH (StM (ResourceT IO) a) data StM (HandlerT site m) a = StH (StM (ResourceT m) a)
liftBaseWith f = GHandler $ \reader -> liftBaseWith f = HandlerT $ \reader ->
liftBaseWith $ \runInBase -> liftBaseWith $ \runInBase ->
f $ liftM StH . runInBase . (\(GHandler r) -> r reader) f $ liftM StH . runInBase . (\(HandlerT r) -> r reader)
restoreM (StH base) = GHandler $ const $ restoreM base restoreM (StH base) = HandlerT $ const $ restoreM base
instance MonadUnsafeIO (GHandler site) where instance MonadThrow m => MonadThrow (HandlerT site m) where
unsafeLiftIO = liftIO monadThrow = lift . monadThrow
instance MonadThrow (GHandler site) where instance (MonadIO m, MonadUnsafeIO m, MonadThrow m, Applicative m) => MonadResource (HandlerT site m) where
monadThrow = liftIO . throwIO liftResourceT = HandlerT . const . liftResourceT
instance MonadResource (GHandler site) where
liftResourceT = lift . liftResourceT
instance MonadLogger (GHandler site) where instance MonadIO m => MonadLogger (HandlerT site m) where
monadLoggerLog a b c d = GHandler $ \hd -> monadLoggerLog a b c d = HandlerT $ \hd ->
liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d) liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
instance Exception e => Failure e (GHandler site) where instance Failure e m => Failure e (HandlerT site m) where
failure = liftIO . throwIO failure = lift . failure
instance Monoid (UniqueList x) where instance Monoid (UniqueList x) where
mempty = UniqueList id mempty = UniqueList id

26
yesod-core/Yesod/Core/Types/Orphan.hs
View File

@ -1,26 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Types.Orphan where
import Yesod.Core.Types
import Control.Monad.Trans.Class
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResource (..))
import Data.Conduit (MonadThrow (..))
instance MonadTrans (HandlerT sub) where
lift = HandlerT . const
instance MonadBase b m => MonadBase b (HandlerT sub m) where
liftBase = lift . liftBase
instance MonadBaseControl b m => MonadBaseControl b (HandlerT sub m)
instance MonadResource m => MonadResource (HandlerT sub m) where
liftResourceT = lift . liftResourceT
instance MonadIO m => MonadIO (HandlerT sub m)
instance MonadThrow m => MonadThrow (HandlerT sub m) where
monadThrow = lift . monadThrow

77
yesod-core/Yesod/Core/Widget.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
@ -10,7 +11,7 @@
-- generator, allowing you to create truly modular HTML components. -- generator, allowing you to create truly modular HTML components.
module Yesod.Core.Widget module Yesod.Core.Widget
( -- * Datatype ( -- * Datatype
GWidget WidgetT
, PageContent (..) , PageContent (..)
-- * Special Hamlet quasiquoter/TH for Widgets -- * Special Hamlet quasiquoter/TH for Widgets
, whamlet , whamlet
@ -39,7 +40,6 @@ module Yesod.Core.Widget
, addScriptRemoteAttrs , addScriptRemoteAttrs
, addScriptEither , addScriptEither
-- * Internal -- * Internal
, unGWidget
, whamletFileWithSettings , whamletFileWithSettings
) where ) where
@ -50,7 +50,6 @@ import Text.Cassius
import Text.Julius import Text.Julius
import Yesod.Routes.Class import Yesod.Routes.Class
import Yesod.Core.Handler (getMessageRender, getUrlRenderParams) import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
import Yesod.Core.Class.MonadLift (lift)
import Text.Shakespeare.I18N (RenderMessage) import Text.Shakespeare.I18N (RenderMessage)
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.Text (Text) import Data.Text (Text)
@ -64,24 +63,26 @@ import Text.Blaze.Html (toHtml, preEscapedToMarkup)
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Class.Handler
import Control.Monad.Trans.Class
preEscapedLazyText :: TL.Text -> Html preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup preEscapedLazyText = preEscapedToMarkup
class ToWidget site a where class Monad m => ToWidget site m a where
toWidget :: a -> GWidget site () toWidget :: a -> WidgetT site m ()
instance render ~ RY site => ToWidget site (render -> Html) where instance (Monad m, render ~ RY site) => ToWidget site m (render -> Html) where
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
instance render ~ RY site => ToWidget site (render -> Css) where instance (Monad m, render ~ RY site) => ToWidget site m (render -> Css) where
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
instance render ~ RY site => ToWidget site (render -> CssBuilder) where instance (Monad m, render ~ RY site) => ToWidget site m (render -> CssBuilder) where
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
instance render ~ RY site => ToWidget site (render -> Javascript) where instance (Monad m, render ~ RY site) => ToWidget site m (render -> Javascript) where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
instance (site' ~ site) => ToWidget site' (GWidget site ()) where instance (site' ~ site, Monad m) => ToWidget site' m (WidgetT site m ()) where
toWidget = id toWidget = id
instance ToWidget site Html where instance Monad m => ToWidget site m Html where
toWidget = toWidget . const toWidget = toWidget . const
-- | Allows adding some CSS to the page with a specific media type. -- | Allows adding some CSS to the page with a specific media type.
@ -91,16 +92,17 @@ class ToWidgetMedia site a where
-- | Add the given content to the page, but only for the given media type. -- | Add the given content to the page, but only for the given media type.
-- --
-- Since 1.2 -- Since 1.2
toWidgetMedia :: Text -- ^ media value toWidgetMedia :: Monad m
=> Text -- ^ media value
-> a -> a
-> GWidget site () -> WidgetT site m ()
instance render ~ RY site => ToWidgetMedia site (render -> Css) where instance render ~ RY site => ToWidgetMedia site (render -> Css) where
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where 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 toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
class ToWidgetBody site a where class ToWidgetBody site a where
toWidgetBody :: a -> GWidget site () toWidgetBody :: Monad m => a -> WidgetT site m ()
instance render ~ RY site => ToWidgetBody site (render -> Html) where instance render ~ RY site => ToWidgetBody site (render -> Html) where
toWidgetBody = toWidget toWidgetBody = toWidget
@ -110,7 +112,7 @@ instance ToWidgetBody site Html where
toWidgetBody = toWidget toWidgetBody = toWidget
class ToWidgetHead site a where class ToWidgetHead site a where
toWidgetHead :: a -> GWidget site () toWidgetHead :: Monad m => a -> WidgetT site m ()
instance render ~ RY site => ToWidgetHead site (render -> Html) where instance render ~ RY site => ToWidgetHead site (render -> Html) where
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
@ -125,52 +127,52 @@ instance ToWidgetHead site Html where
-- | Set the page title. Calling 'setTitle' multiple times overrides previously -- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values. -- set values.
setTitle :: Html -> GWidget site () setTitle :: Monad m => Html -> WidgetT site m ()
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty 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 the page title. Calling 'setTitle' multiple times overrides previously
-- set values. -- set values.
setTitleI :: RenderMessage site msg => msg -> GWidget site () setTitleI :: (Monad m, RenderMessage site msg) => msg -> WidgetT site m ()
setTitleI msg = do setTitleI msg = do
mr <- lift getMessageRender mr <- getMessageRender
setTitle $ toHtml $ mr msg setTitle $ toHtml $ mr msg
-- | Link to the specified local stylesheet. -- | Link to the specified local stylesheet.
addStylesheet :: Route site -> GWidget site () addStylesheet :: Monad m => Route site -> WidgetT site m ()
addStylesheet = flip addStylesheetAttrs [] addStylesheet = flip addStylesheetAttrs []
-- | Link to the specified local stylesheet. -- | Link to the specified local stylesheet.
addStylesheetAttrs :: Route site -> [(Text, Text)] -> GWidget site () addStylesheetAttrs :: Monad m => Route site -> [(Text, Text)] -> WidgetT site m ()
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
-- | Link to the specified remote stylesheet. -- | Link to the specified remote stylesheet.
addStylesheetRemote :: Text -> GWidget site () addStylesheetRemote :: Monad m => Text -> WidgetT site m ()
addStylesheetRemote = flip addStylesheetRemoteAttrs [] addStylesheetRemote = flip addStylesheetRemoteAttrs []
-- | Link to the specified remote stylesheet. -- | Link to the specified remote stylesheet.
addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget site () addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> WidgetT site m ()
addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
addStylesheetEither :: Either (Route site) Text -> GWidget site () addStylesheetEither :: Monad m => Either (Route site) Text -> WidgetT site m ()
addStylesheetEither = either addStylesheet addStylesheetRemote addStylesheetEither = either addStylesheet addStylesheetRemote
addScriptEither :: Either (Route site) Text -> GWidget site () addScriptEither :: Monad m => Either (Route site) Text -> WidgetT site m ()
addScriptEither = either addScript addScriptRemote addScriptEither = either addScript addScriptRemote
-- | Link to the specified local script. -- | Link to the specified local script.
addScript :: Route site -> GWidget site () addScript :: Monad m => Route site -> WidgetT site m ()
addScript = flip addScriptAttrs [] addScript = flip addScriptAttrs []
-- | Link to the specified local script. -- | Link to the specified local script.
addScriptAttrs :: Route site -> [(Text, Text)] -> GWidget site () addScriptAttrs :: Monad m => Route site -> [(Text, Text)] -> WidgetT site m ()
addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
-- | Link to the specified remote script. -- | Link to the specified remote script.
addScriptRemote :: Text -> GWidget site () addScriptRemote :: Monad m => Text -> WidgetT site m ()
addScriptRemote = flip addScriptRemoteAttrs [] addScriptRemote = flip addScriptRemoteAttrs []
-- | Link to the specified remote script. -- | Link to the specified remote script.
addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget site () addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> WidgetT site m ()
addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
whamlet :: QuasiQuoter whamlet :: QuasiQuoter
@ -194,27 +196,22 @@ rules = do
return $ InfixE (Just g) bind (Just e') return $ InfixE (Just g) bind (Just e')
let ur f = do let ur f = do
let env = NP.Env let env = NP.Env
(Just $ helper [|liftW getUrlRenderParams|]) (Just $ helper [|getUrlRenderParams|])
(Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|]) (Just $ helper [|liftM (toHtml .) getMessageRender|])
f env f env
return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: RenderMessage site message ihamletToRepHtml :: (HandlerReader m, RenderMessage (HandlerSite m) message)
=> HtmlUrlI18n message (Route site) => HtmlUrlI18n message (Route (HandlerSite m))
-> GHandler site Html -> m Html
ihamletToRepHtml ih = do ihamletToRepHtml ih = do
urender <- getUrlRenderParams urender <- getUrlRenderParams
mrender <- getMessageRender mrender <- getMessageRender
return $ ih (toHtml . mrender) urender return $ ih (toHtml . mrender) urender
tell :: GWData (Route site) -> GWidget site () tell :: Monad m => GWData (Route site) -> WidgetT site m ()
tell w = GWidget $ return ((), w) tell w = WidgetT $ return ((), w)
-- | Type-restricted version of @lift@. Used internally to create better error
-- messages.
liftW :: GHandler site a -> GWidget site a
liftW = lift
toUnique :: x -> UniqueList x toUnique :: x -> UniqueList x
toUnique = UniqueList . (:) toUnique = UniqueList . (:)

4
yesod-core/yesod-core.cabal
View File

@ -82,7 +82,7 @@ library
, fast-logger >= 0.2 , fast-logger >= 0.2
, monad-logger >= 0.3.1 && < 0.4 , monad-logger >= 0.3.1 && < 0.4
, conduit >= 0.5 , conduit >= 0.5
, resourcet >= 0.4 && < 0.5 , resourcet >= 0.4.6 && < 0.5
, lifted-base >= 0.1 , lifted-base >= 0.1
, attoparsec-conduit , attoparsec-conduit
, blaze-html >= 0.5 , blaze-html >= 0.5
@ -101,12 +101,10 @@ library
Yesod.Core.Class.Handler Yesod.Core.Class.Handler
Yesod.Core.Internal.Util Yesod.Core.Internal.Util
Yesod.Core.Internal.Response Yesod.Core.Internal.Response
Yesod.Core.Class.MonadLift
Yesod.Core.Internal.Run Yesod.Core.Internal.Run
Yesod.Core.Class.Yesod Yesod.Core.Class.Yesod
Yesod.Core.Class.Dispatch Yesod.Core.Class.Dispatch
Yesod.Core.Class.Breadcrumbs Yesod.Core.Class.Breadcrumbs
Yesod.Core.Types.Orphan
Paths_yesod_core Paths_yesod_core
ghc-options: -Wall ghc-options: -Wall