From 429534617156936040ae7259eb0e2e74ce7d8b99 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 17 Mar 2013 11:38:33 +0200 Subject: [PATCH] Split files up a bit more --- yesod-core/Yesod/Core/Class/Handler.hs | 3 - yesod-core/Yesod/Core/Dispatch.hs | 128 +--------------- yesod-core/Yesod/Core/Internal/TH.hs | 144 ++++++++++++++++++ yesod-core/Yesod/Core/Json.hs | 4 - yesod-core/Yesod/Core/Widget.hs | 6 +- yesod-core/test/YesodCoreTest/Links.hs | 1 - .../test/YesodCoreTest/NoOverloadedStrings.hs | 1 - yesod-core/yesod-core.cabal | 1 + 8 files changed, 150 insertions(+), 138 deletions(-) create mode 100644 yesod-core/Yesod/Core/Internal/TH.hs diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index e94f8d5f..d778f937 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -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) diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index c71d61a1..912848e8 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs new file mode 100644 index 00000000..414c7c43 --- /dev/null +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -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) diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index 27e3ac99..ce9ef337 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Widget.hs b/yesod-core/Yesod/Core/Widget.hs index eda44ebd..796ccd43 100644 --- a/yesod-core/Yesod/Core/Widget.hs +++ b/yesod-core/Yesod/Core/Widget.hs @@ -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 diff --git a/yesod-core/test/YesodCoreTest/Links.hs b/yesod-core/test/YesodCoreTest/Links.hs index 998c1e5d..f030707c 100644 --- a/yesod-core/test/YesodCoreTest/Links.hs +++ b/yesod-core/test/YesodCoreTest/Links.hs @@ -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 diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index 0abb919e..746c91b5 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs @@ -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) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 8ba741c3..85d4f832 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -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