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

Some cleanup

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-14 10:23:57 +02:00
parent 9c4cd573b4
commit 15bbd54e12
14 changed files with 63 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -70,9 +70,6 @@ import Yesod.Core.Content
import Yesod.Core.Dispatch
import Yesod.Core.Handler
import Yesod.Core.Class.Handler
import Data.IORef (readIORef, newIORef)
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
import Yesod.Core.Widget
import Yesod.Core.Json
import Yesod.Core.Types
@ -80,8 +77,6 @@ import Text.Shakespeare.I18N
import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)
import Control.Monad.Logger
import Control.Monad.Trans.Resource (MonadResource, liftResourceT)
import Control.Monad.Trans.Class (MonadTrans)
import Yesod.Core.Internal.Session
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch

36
yesod-core/Yesod/Core/Class/Dispatch.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
@ -12,9 +13,7 @@ import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Handler
import Yesod.Core.Internal.Request (textQueryString)
import Yesod.Core.Internal.Run
import Control.Monad.Trans.Control (MonadBaseControl)
-- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly.
@ -22,36 +21,23 @@ class Yesod site => YesodDispatch site where
yesodDispatch :: YesodRunnerEnv site -> W.Application
class YesodSubDispatch sub m where
yesodSubDispatch
:: (m TypedContent
-> YesodRunnerEnv (HandlerSite m)
-> Maybe (Route (HandlerSite m))
-> W.Application)
-> (HandlerSite m -> sub)
-> (Route sub -> Route (HandlerSite m))
-> YesodRunnerEnv (HandlerSite m)
-> W.Application
yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m
-> W.Application
instance YesodSubDispatch WaiSubsite master where
yesodSubDispatch _ toSub _ YesodRunnerEnv { yreSite = site } req =
yesodSubDispatch YesodSubRunnerEnv {..} req =
app req
where
WaiSubsite app = toSub site
WaiSubsite app = ysreGetSub $ yreSite $ ysreParentEnv
-- | A helper function for creating YesodSubDispatch instances, used by the
-- internal generated code.
subHelper :: Monad m
=> (HandlerT parent m TypedContent
-> YesodRunnerEnv parent
-> Maybe (Route parent)
-> W.Application)
-> (parent -> child)
-> (Route child -> Route parent)
-> HandlerT child (HandlerT parent m) TypedContent
-> YesodRunnerEnv parent
subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained.
=> HandlerT child (HandlerT parent m) TypedContent
-> YesodSubRunnerEnv child parent (HandlerT parent m)
-> Maybe (Route child)
-> W.Application
subHelper parentRunner getSub toMaster handlert env route =
parentRunner base env (fmap toMaster route)
subHelper handlert YesodSubRunnerEnv {..} route =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)
where
base = stripHandlerT (fmap toTypedContent handlert) getSub toMaster route
base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route

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

@ -6,9 +6,6 @@
module Yesod.Core.Class.Handler where
import Yesod.Core.Types
import Control.Monad.Trans.Class (MonadTrans)
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control
import Data.IORef.Lifted (atomicModifyIORef)
import Control.Exception.Lifted (throwIO)
import Control.Monad.Base

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

@ -7,7 +7,6 @@ module Yesod.Core.Class.Yesod where
import Control.Monad.Logger (logErrorS)
import Yesod.Core.Content
import Yesod.Core.Handler
import Yesod.Core.Class.Handler
import Yesod.Routes.Class
@ -18,8 +17,6 @@ import Control.Monad (forM)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther),
LogSource)
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Aeson (object, (.=))

62
yesod-core/Yesod/Core/Dispatch.hs
View File

@ -128,6 +128,25 @@ mkYesodGeneral name args clazzes isSub resS = do
subCons = conT $ mkName name
subArgs = map (varT. mkName) args
mkMDS :: Q Exp -> MkDispatchSettings
mkMDS rh = MkDispatchSettings
{ mdsRunHandler = rh
, mdsSubDispatcher =
[|\parentRunner getSub toParent env -> yesodSubDispatch
YesodSubRunnerEnv
{ ysreParentRunner = parentRunner
, ysreGetSub = getSub
, ysreToParentRoute = toParent
, ysreParentEnv = env
}
|]
, mdsGetPathInfo = [|W.pathInfo|]
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
, mdsMethod = [|W.requestMethod|]
, mds404 = [|notFound >> return ()|]
, mds405 = [|badMethod >> return ()|]
}
-- | If the generation of @'YesodDispatch'@ instance require finer
-- control of the types, contexts etc. using this combinator. You will
-- hardly need this generality. However, in certain situations, like
@ -141,57 +160,22 @@ mkDispatchInstance :: CxtQ -- ^ The context
mkDispatchInstance context _sub master res = do
let yDispatch = conT ''YesodDispatch `appT` master
thisDispatch = do
clause' <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [|yesodRunner|]
, mdsSubDispatcher = [|yesodSubDispatch|]
, mdsGetPathInfo = [|W.pathInfo|]
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
, mdsMethod = [|W.requestMethod|]
, mds404 = [|notFound >> return ()|]
, mds405 = [|badMethod >> return ()|]
} res
clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res
return $ FunD 'yesodDispatch [clause']
in sequence [instanceD context yDispatch [thisDispatch]]
mkYesodSubDispatch :: [ResourceTree String] -> Q Exp
mkYesodSubDispatch res = do
parentRunner <- newName "parentRunner"
getSub <- newName "getSub"
toMaster <- newName "toMaster"
runner <- newName "runner"
clause' <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [|subHelper
$(return $ VarE parentRunner)
$(return $ VarE getSub)
$(return $ VarE toMaster)
. fmap toTypedContent
|]
, mdsSubDispatcher = [|yesodSubDispatch|]
, mdsGetPathInfo = [|W.pathInfo|]
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
, mdsMethod = [|W.requestMethod|]
, mds404 = [|notFound >> return ()|]
, mds405 = [|badMethod >> return ()|]
} res
clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
inner <- newName "inner"
let innerFun = FunD inner [clause']
runnerFun = FunD runner
[ Clause
[]
(NormalB $ VarE 'subHelper
`AppE` VarE parentRunner
`AppE` VarE getSub
`AppE` VarE toMaster
)
[]
]
helper <- newName "helper"
let fun = FunD helper
[ Clause
[VarP parentRunner, VarP getSub, VarP toMaster]
[]
(NormalB $ VarE inner)
[innerFun, runnerFun]
[innerFun]
]
return $ LetE [fun] (VarE helper)

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

@ -163,7 +163,7 @@ import Yesod.Core.Content (ToTypedContent (..), simpleConte
import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToMarkup, toHtml)
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Control.Monad.Trans.Resource (ResourceT)
import Data.Dynamic (fromDynamic, toDyn)
import qualified Data.IORef as I
import Data.Maybe (listToMaybe)

5
yesod-core/Yesod/Core/Internal/Run.hs
View File

@ -7,18 +7,15 @@
module Yesod.Core.Internal.Run where
import Yesod.Core.Internal.Response
import Yesod.Core.Class.Handler
import Blaze.ByteString.Builder (toByteString)
import Control.Applicative ((<$>))
import Control.Exception (fromException)
import Control.Exception.Lifted (catch)
import Control.Monad (join)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
liftLoc)
import Control.Monad.Trans.Resource (runResourceT, transResourceT, ResourceT, joinResourceT, withInternalState, runInternalState)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.IORef as I

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

@ -25,7 +25,6 @@ import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
import Yesod.Core.Class.Handler
import Yesod.Core.Widget (WidgetT)
import Yesod.Routes.Class
import Control.Applicative ((<$>))
import Control.Monad (join)
import qualified Data.Aeson as J
import qualified Data.Aeson.Parser as JP
@ -38,7 +37,6 @@ import Network.Wai (requestBody, requestHeaders)
import Network.Wai.Parse (parseHttpAccept)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (listToMaybe)
import Control.Monad.Trans.Class (lift)
import Control.Monad (liftM)
import Control.Monad.Trans.Resource (liftResourceT)

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

@ -12,17 +12,15 @@ import qualified Blaze.ByteString.Builder.Char.Utf8
import Control.Applicative (Applicative (..))
import Control.Applicative ((<$>))
import Control.Arrow (first)
import Control.Exception (Exception, throwIO)
import Control.Exception (Exception)
import Control.Failure (Failure (..))
import Control.Monad (liftM, ap)
import Control.Monad.Trans.Class (MonadTrans)
import qualified Control.Monad.Trans.Class as Trans
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel, LogSource,
MonadLogger (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush, MonadThrow (..),
@ -55,7 +53,7 @@ import Text.Hamlet (HtmlUrl)
import Text.Julius (JavascriptUrl)
import Web.Cookie (SetCookie)
import Yesod.Core.Internal.Util (getTime, putTime)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Class (MonadTrans (..))
import Yesod.Routes.Class (RenderRoute (..))
-- Sessions
@ -193,6 +191,19 @@ data YesodRunnerEnv site = YesodRunnerEnv
, yreSessionBackend :: !(Maybe SessionBackend)
}
data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv
{ ysreParentRunner :: !(ParentRunner parent parentMonad)
, ysreGetSub :: !(parent -> sub)
, ysreToParentRoute :: !(Route sub -> Route parent)
, ysreParentEnv :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner?
}
type ParentRunner parent m
= m TypedContent
-> YesodRunnerEnv parent
-> Maybe (Route parent)
-> W.Application
-- | A generic handler monad, which can have a different subsite and master
-- site. We define a newtype for better error message.
newtype HandlerT site m a = HandlerT

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

@ -55,7 +55,6 @@ import Text.Cassius
import Text.Julius
import Yesod.Routes.Class
import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
import Control.Monad.Trans.Resource (transResourceT)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Shakespeare.I18N (RenderMessage)
import Control.Monad (liftM)
@ -71,7 +70,6 @@ import qualified Data.Text.Lazy as TL
import Yesod.Core.Types
import Yesod.Core.Class.Handler
import Control.Monad.Trans.Class
preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup

2
yesod-core/test/YesodCoreTest/CleanPath.hs
View File

@ -30,7 +30,7 @@ instance RenderRoute Subsite where
renderRoute (SubsiteRoute x) = (x, [])
instance YesodSubDispatch Subsite master where
yesodSubDispatch _ _ _ _ req = return $ responseLBS
yesodSubDispatch _ req = return $ responseLBS
status200
[ ("Content-Type", "SUBSITE")
] $ L8.pack $ show (pathInfo req)

5
yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
View File

@ -14,10 +14,7 @@ import qualified Data.ByteString.Lazy.Char8 as L8
import Control.Monad.Trans.Class
getSubsite :: a -> Subsite
getSubsite = const Subsite
instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesSubsite)
getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)
getBarR :: Monad m => m T.Text
getBarR = return $ T.pack "BarR"

14
yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs
View File

@ -1,18 +1,22 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
module YesodCoreTest.NoOverloadedStringsSub where
import Yesod.Core
import Network.Wai
import Network.Wai.Test
import Data.Monoid (mempty)
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as L8
import Yesod.Core.Types
data Subsite = Subsite
data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application)
mkYesodSubData "Subsite" [parseRoutes|
/bar BarR GET
/baz BazR GET
/bin BinR GET
|]
instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where
yesodSubDispatch ysre =
f ysre
where
Subsite f = ysreGetSub ysre $ yreSite $ ysreParentEnv ysre

2
yesod-core/test/YesodCoreTest/RequestBodySize.hs
View File

@ -18,8 +18,6 @@ import qualified Data.Text as T
import Data.Conduit
import Data.Conduit.List (consume)
import Data.Conduit.Binary (isolate)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Resource
data Y = Y