Split files up a bit more

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)

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

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)

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

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

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

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)

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