Refactor so that mkYesod and mkYesodDispatch use the context parser

yesod-core/Yesod/Core/Internal/TH.hs

@@ -16,16 +16,11 @@ import Language.Haskell.TH.Syntax
 import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
-#if MIN_VERSION_base(4,8,0)
-import Data.List (foldl', uncons)
-#else
 import Data.List (foldl')
-#endif
 #if __GLASGOW_HASKELL__ < 710
 import Control.Applicative ((<$>))
 #endif
 import Control.Monad (replicateM, void)
-import Data.Either (partitionEithers)
 import Text.Parsec (parse, many1, many, eof, try, option, sepBy1)
 import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
@@ -42,7 +37,7 @@ import Yesod.Core.Internal.Run
 mkYesod :: String -- ^ name of the argument datatype
         -> [ResourceTree String]
         -> Q [Dec]
-mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return
+mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return
 
 {-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name. (https://github.com/yesodweb/yesod/pull/1366)" #-}
 mkYesodWith :: [[String]]
@@ -50,24 +45,29 @@ mkYesodWith :: [[String]]
             -> [String]
             -> [ResourceTree String]
             -> Q [Dec]
-mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral' cxts name args False return
+mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return
 
 -- | 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 = mkYesodDataGeneral name False
+mkYesodData name resS = fst <$> mkYesodWithParser name False return resS
 
 mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodSubData name = mkYesodDataGeneral name True
+mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS
 
-mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
-mkYesodDataGeneral name isSub res = do
+-- | Parses contexts and type arguments out of name before generating TH.
+mkYesodWithParser :: String                    -- ^ foundation type
+                  -> Bool                      -- ^ is this a subsite
+                  -> (Exp -> Q Exp)            -- ^ unwrap handler
+                  -> [ResourceTree String]
+                  -> Q([Dec],[Dec])
+mkYesodWithParser name isSub f resS = do
     let (name', rest, cxt) = case parse parseName "" name of
             Left err -> error $ show err
             Right a -> a
-    fst <$> mkYesodGeneral' cxt name' rest isSub return res
+    mkYesodGeneral cxt name' rest isSub f resS
 
     where
         parseName = do
@@ -101,7 +101,7 @@ mkYesodDataGeneral name isSub res = do
 
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return
+mkYesodDispatch name = fmap snd . mkYesodWithParser name False return
 
 -- | Get the Handler and Widget type synonyms for the given site.
 masterTypeSyns :: [Name] -> Type -> [Dec]
@@ -112,25 +112,14 @@ masterTypeSyns vs site =
       $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
     ]
 
--- | 'Left' arguments indicate a monomorphic type, a 'Right' argument
---   indicates a polymorphic type, and provides the list of classes
---   the type must be instance of.
-mkYesodGeneral :: String                    -- ^ foundation type
-               -> [String]                  -- ^ arguments for the type
-               -> Bool                      -- ^ is this a subsite
-               -> (Exp -> Q Exp)            -- ^ unwrap handler
-               -> [ResourceTree String]
-               -> Q([Dec],[Dec])
-mkYesodGeneral = mkYesodGeneral' []
-
-mkYesodGeneral' :: [[String]]               -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
+mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
                -> String                    -- ^ foundation type
                -> [String]                  -- ^ arguments for the type
                -> Bool                      -- ^ is this a subsite
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral' appCxt' namestr mtys isSub f resS = do
+mkYesodGeneral appCxt' namestr mtys isSub f resS = do
     let appCxt = fmap (\(c:rest) -> 
 #if MIN_VERSION_template_haskell(2,10,0)
             foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest
@@ -183,12 +172,6 @@ mkYesodGeneral' appCxt' namestr mtys isSub f resS = do
             ]
     return (dataDec, dispatchDec)
 
-#if !MIN_VERSION_base(4,8,0)
-    where
-        uncons (h:t) = Just (h,t)
-        uncons _ = Nothing
-#endif
-
 mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
 mkMDS f rh = MkDispatchSettings
     { mdsRunHandler = rh