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

Split files up a bit more

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-17 11:38:33 +02:00
parent 172f706924
commit 4295346171
8 changed files with 150 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -10,9 +10,6 @@ module Yesod.Core.Class.Handler
) where
import Yesod.Core.Types
import Data.IORef.Lifted (atomicModifyIORef)
import Control.Exception.Lifted (throwIO)
import Control.Monad.Base
import Data.Monoid (mempty)
import Control.Monad (liftM)
import Control.Monad.IO.Class (MonadIO, liftIO)

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

@ -28,11 +28,9 @@ module Yesod.Core.Dispatch
) where
import Prelude hiding (exp)
import Yesod.Core.Handler
import Yesod.Core.Internal.TH
import Web.PathPieces
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
@ -43,135 +41,11 @@ import Data.Monoid (mappend)
import qualified Data.ByteString as S
import qualified Blaze.ByteString.Builder
import Network.HTTP.Types (status301)
import Yesod.Routes.TH
import Yesod.Routes.Parse
import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run
import Yesod.Core.Class.Handler
-- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
-- Use 'parseRoutes' to create the 'Resource's.
mkYesod :: String -- ^ name of the argument datatype
-> [ResourceTree String]
-> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
-- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter.
-- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not
-- executable by itself, but instead provides functionality to
-- be embedded in other sites.
mkYesodSub :: String -- ^ name of the argument datatype
-> Cxt
-> [ResourceTree String]
-> Q [Dec]
mkYesodSub name clazzes =
fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
where
(name':rest) = words name
-- | Sometimes, you will want to declare your routes in one file and define
-- your handlers elsewhere. For example, this is the only way to break up a
-- monolithic file into smaller parts. Use this function, paired with
-- 'mkYesodDispatch', to do just that.
mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodData name res = mkYesodDataGeneral name [] False res
mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodSubData name res = mkYesodDataGeneral name [] True res
mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec]
mkYesodDataGeneral name clazzes isSub res = do
let (name':rest) = words name
(x, _) <- mkYesodGeneral name' rest clazzes isSub res
let rname = mkName $ "resources" ++ name
eres <- lift res
let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
, FunD rname [Clause [] (NormalB eres) []]
]
return $ x ++ y
-- | See 'mkYesodData'.
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
mkYesodGeneral :: String -- ^ foundation type
-> [String] -- ^ arguments for the type
-> Cxt -- ^ the type constraints
-> Bool -- ^ it this a subsite
-> [ResourceTree String]
-> Q([Dec],[Dec])
mkYesodGeneral name args clazzes isSub resS = do
subsite <- sub
masterTypeSyns <- if isSub then return []
else sequence [handler, widget]
renderRouteDec <- mkRenderRouteInstance subsite res
dispatchDec <- mkDispatchInstance context (if isSub then Just sub else Nothing) master res
return (renderRouteDec ++ masterTypeSyns, dispatchDec)
where sub = foldl appT subCons subArgs
master = if isSub then (varT $ mkName "m") else sub
context = if isSub then cxt $ map return clazzes
else return []
handler = tySynD (mkName "Handler") [] [t| HandlerT $master IO |]
widget = tySynD (mkName "Widget") [] [t| WidgetT $master IO () |]
res = map (fmap parseType) resS
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
-- when writing library/plugin for yesod, this combinator becomes
-- handy.
mkDispatchInstance :: CxtQ -- ^ The context
-> Maybe TypeQ -- ^ The subsite type
-> TypeQ -- ^ The master site type
-> [ResourceTree a] -- ^ The resource
-> DecsQ
mkDispatchInstance context _sub master res = do
let yDispatch = conT ''YesodDispatch `appT` master
thisDispatch = do
clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res
return $ FunD 'yesodDispatch [clause']
in sequence [instanceD context yDispatch [thisDispatch]]
mkYesodSubDispatch :: [ResourceTree String] -> Q Exp
mkYesodSubDispatch res = do
clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
inner <- newName "inner"
let innerFun = FunD inner [clause']
helper <- newName "helper"
let fun = FunD helper
[ Clause
[]
(NormalB $ VarE inner)
[innerFun]
]
return $ LetE [fun] (VarE helper)
-- | Convert the given argument into a WAI application, executable with any WAI
-- handler. Note that, in versions of Yesod prior to 1.2, this would include

144
yesod-core/Yesod/Core/Internal/TH.hs Normal file
View File

@ -0,0 +1,144 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.Core.Internal.TH where
import Prelude hiding (exp)
import Yesod.Core.Handler
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
import Data.ByteString.Lazy.Char8 ()
import Yesod.Routes.TH
import Yesod.Routes.Parse
import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run
-- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
-- Use 'parseRoutes' to create the 'Resource's.
mkYesod :: String -- ^ name of the argument datatype
-> [ResourceTree String]
-> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
-- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter.
-- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not
-- executable by itself, but instead provides functionality to
-- be embedded in other sites.
mkYesodSub :: String -- ^ name of the argument datatype
-> Cxt
-> [ResourceTree String]
-> Q [Dec]
mkYesodSub name clazzes =
fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
where
(name':rest) = words name
-- | Sometimes, you will want to declare your routes in one file and define
-- your handlers elsewhere. For example, this is the only way to break up a
-- monolithic file into smaller parts. Use this function, paired with
-- 'mkYesodDispatch', to do just that.
mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodData name res = mkYesodDataGeneral name [] False res
mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodSubData name res = mkYesodDataGeneral name [] True res
mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec]
mkYesodDataGeneral name clazzes isSub res = do
let (name':rest) = words name
(x, _) <- mkYesodGeneral name' rest clazzes isSub res
let rname = mkName $ "resources" ++ name
eres <- lift res
let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
, FunD rname [Clause [] (NormalB eres) []]
]
return $ x ++ y
-- | See 'mkYesodData'.
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
mkYesodGeneral :: String -- ^ foundation type
-> [String] -- ^ arguments for the type
-> Cxt -- ^ the type constraints
-> Bool -- ^ it this a subsite
-> [ResourceTree String]
-> Q([Dec],[Dec])
mkYesodGeneral name args clazzes isSub resS = do
subsite <- sub
masterTypeSyns <- if isSub then return []
else sequence [handler, widget]
renderRouteDec <- mkRenderRouteInstance subsite res
dispatchDec <- mkDispatchInstance context (if isSub then Just sub else Nothing) master res
return (renderRouteDec ++ masterTypeSyns, dispatchDec)
where sub = foldl appT subCons subArgs
master = if isSub then (varT $ mkName "m") else sub
context = if isSub then cxt $ map return clazzes
else return []
handler = tySynD (mkName "Handler") [] [t| HandlerT $master IO |]
widget = tySynD (mkName "Widget") [] [t| WidgetT $master IO () |]
res = map (fmap parseType) resS
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
-- when writing library/plugin for yesod, this combinator becomes
-- handy.
mkDispatchInstance :: CxtQ -- ^ The context
-> Maybe TypeQ -- ^ The subsite type
-> TypeQ -- ^ The master site type
-> [ResourceTree a] -- ^ The resource
-> DecsQ
mkDispatchInstance context _sub master res = do
let yDispatch = conT ''YesodDispatch `appT` master
thisDispatch = do
clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res
return $ FunD 'yesodDispatch [clause']
in sequence [instanceD context yDispatch [thisDispatch]]
mkYesodSubDispatch :: [ResourceTree String] -> Q Exp
mkYesodSubDispatch res = do
clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
inner <- newName "inner"
let innerFun = FunD inner [clause']
helper <- newName "helper"
let fun = FunD helper
[ Clause
[]
(NormalB $ VarE inner)
[innerFun]
]
return $ LetE [fun] (VarE helper)

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

@ -27,7 +27,6 @@ import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
import Yesod.Core.Class.Handler
import Yesod.Core.Widget (WidgetT)
import Yesod.Routes.Class
import Control.Monad (join)
import qualified Data.Aeson as J
import qualified Data.Aeson.Parser as JP
import Data.Aeson ((.=), object)
@ -35,12 +34,9 @@ import Data.Conduit.Attoparsec (sinkParser)
import Data.Text (pack)
import qualified Data.Vector as V
import Data.Conduit
import Network.Wai (requestBody, requestHeaders)
import Network.Wai.Parse (parseHttpAccept)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (listToMaybe)
import Control.Monad (liftM)
import Control.Monad.Trans.Resource (liftResourceT)
-- | Provide both an HTML and JSON representation for a piece of
-- data, using the default layout for the HTML output

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

@ -70,7 +70,6 @@ import qualified Data.Text.Lazy as TL
import Yesod.Core.Types
import Yesod.Core.Class.Handler
import Text.Shakespeare.I18N (renderMessage)
preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup
@ -197,9 +196,12 @@ 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 <- [|toWidget|]
ah <- [|asWidgetT . toWidget|]
let helper qg f = do
x <- newName "urender"
e <- f $ VarE x

1
yesod-core/test/YesodCoreTest/Links.hs
View File

@ -10,7 +10,6 @@ import Text.Hamlet
import Network.Wai
import Network.Wai.Test
import Data.Text (Text)
import Control.Monad.IO.Class (liftIO)
import Blaze.ByteString.Builder (toByteString)
data Y = Y

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

@ -11,7 +11,6 @@ import Network.Wai.Test
import Data.Monoid (mempty)
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as L8
import Control.Monad.Trans.Class
getSubsite :: a -> Subsite
getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)

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

@ -103,6 +103,7 @@ library
Yesod.Core.Internal.Util
Yesod.Core.Internal.Response
Yesod.Core.Internal.Run
Yesod.Core.Internal.TH
Yesod.Core.Class.Yesod
Yesod.Core.Class.Dispatch
Yesod.Core.Class.Breadcrumbs