Merge pull request #1478 from jprider63/master

Update `mkYesodWith` and refactor so that `mkYesod` uses 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)
 
@@ -36,35 +31,48 @@ 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.
+-- is used for creating sites, /not/ subsites. See 'mkYesodSubData' and 'mkYesodSubDispatch' for the latter.
 -- Use 'parseRoutes' to create the 'Resource's.
+--
+-- Contexts and type variables in the name of the datatype are parsed. 
+-- For example, a datatype @App a@ with typeclass constraint @MyClass a@ can be written as @\"(MyClass a) => App a\"@.
 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
 
-mkYesodWith :: String
+{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
-            -> [Either String [String]]
+-- | Similar to 'mkYesod', except contexts and type variables are not parsed. 
+-- Instead, they are explicitly provided. 
+-- You can write @(MyClass a) => App a@ with @mkYesodWith [[\"MyClass\",\"a\"]] \"App\" [\"a\"] ...@.
+mkYesodWith :: [[String]] -- ^ list of contexts
+            -> String -- ^ name of the argument datatype
+            -> [String] -- ^ list of type variables
             -> [ResourceTree String]
             -> Q [Dec]
-mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral 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]
+-- | Parses contexts and type arguments out of name before generating TH.
-mkYesodDataGeneral name isSub res = do
+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' (fmap Left rest) isSub return res
+    mkYesodGeneral cxt name' rest isSub f resS
 
     where
         parseName = do
@@ -98,7 +106,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] -- FIXME remove from here, put into the scaffolding itself?
@@ -109,25 +117,14 @@ masterTypeSyns vs site =
       $ ConT ''WidgetFor `AppT` site `AppT` ConT ''()
     ]
 
--- | 'Left' arguments indicate a monomorphic type, a 'Right' argument
+mkYesodGeneral :: [[String]]                -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
---   indicates a polymorphic type, and provides the list of classes
---   the type must be instance of.
-mkYesodGeneral :: String                    -- ^ foundation type
-               -> [Either String [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.
                -> String                    -- ^ foundation type
-               -> [Either String [String]]  -- ^ arguments for the type
+               -> [String]                  -- ^ arguments for the type
                -> Bool                      -- ^ is this a subsite
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral' appCxt' namestr args 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
@@ -150,36 +147,21 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do
                          DataD _ _ vs _ _ -> length vs
                          NewtypeD _ _ vs _ _ -> length vs
 #endif
+                         TySynD _ vs _ -> length vs
                          _ -> 0
                      _ -> 0
                _ -> return 0
     let name = mkName namestr
-        (mtys,_) = partitionEithers args
     -- Generate as many variable names as the arity indicates
     vns <- replicateM (arity - length mtys) $ newName "t"
         -- Base type (site type with variables)
-    let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $
+    let argtypes = fmap nameToType mtys ++ fmap VarT vns
-          foldr (\arg (xs,vns',cs) ->
-                   case arg of
-                     Left  t  -> 
-                                 ( nameToType t:xs, vns', cs )
-                     Right ts -> 
-                                 let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in
-                                 ( VarT n : xs, ns
-                                 , fmap (\t ->
-#if MIN_VERSION_template_haskell(2,10,0)
-                                               AppT (ConT $ mkName t) (VarT n)
-#else
-                                               ClassP (mkName t) [VarT n]
-#endif
-                                          ) ts ++ cs )
-                 ) ([],vns,[]) args
         site = foldl' AppT (ConT name) argtypes
         res = map (fmap (parseType . dropBracket)) resS
-    renderRouteDec <- mkRenderRouteInstance' appCxt site res
+    renderRouteDec <- mkRenderRouteInstance appCxt site res
-    routeAttrsDec  <- mkRouteAttrsInstance' appCxt site res
+    routeAttrsDec  <- mkRouteAttrsInstance appCxt site res
-    dispatchDec    <- mkDispatchInstance site cxt f res
+    dispatchDec    <- mkDispatchInstance site appCxt f res
-    parseRoute <- mkParseRouteInstance' appCxt site res
+    parseRoute <- mkParseRouteInstance appCxt site res
     let rname = mkName $ "resources" ++ namestr
     eres <- lift resS
     let resourcesDec =
@@ -195,12 +177,6 @@ mkYesodGeneral' appCxt' namestr args 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

yesod-core/Yesod/Routes/TH/ParseRoute.hs

@@ -3,7 +3,6 @@
 module Yesod.Routes.TH.ParseRoute
     ( -- ** ParseRoute
       mkParseRouteInstance
-    , mkParseRouteInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -12,11 +11,8 @@ import Data.Text (Text)
 import Yesod.Routes.Class
 import Yesod.Routes.TH.Dispatch
 
-mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
+mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
-mkParseRouteInstance = mkParseRouteInstance' []
+mkParseRouteInstance cxt typ ress = do
-
-mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
-mkParseRouteInstance' cxt typ ress = do
     cls <- mkDispatchClause
         MkDispatchSettings
             { mdsRunHandler = [|\_ _ x _ -> x|]

yesod-core/Yesod/Routes/TH/RenderRoute.hs

@@ -2,7 +2,6 @@
 module Yesod.Routes.TH.RenderRoute
     ( -- ** RenderRoute
       mkRenderRouteInstance
-    , mkRenderRouteInstance'
     , mkRouteCons
     , mkRenderRouteClauses
     ) where
@@ -148,14 +147,8 @@ mkRenderRouteClauses =
 -- This includes both the 'Route' associated type and the
 -- 'renderRoute' method.  This function uses both 'mkRouteCons' and
 -- 'mkRenderRouteClasses'.
-mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec]
+mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
-mkRenderRouteInstance = mkRenderRouteInstance' []
+mkRenderRouteInstance cxt typ ress = do
-
--- | A more general version of 'mkRenderRouteInstance' which takes an
--- additional context.
-
-mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
-mkRenderRouteInstance' cxt typ ress = do
     cls <- mkRenderRouteClauses ress
     (cons, decs) <- mkRouteCons ress
 #if MIN_VERSION_template_haskell(2,12,0)

yesod-core/Yesod/Routes/TH/RouteAttrs.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Routes.TH.RouteAttrs
     ( mkRouteAttrsInstance
-    , mkRouteAttrsInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -15,11 +14,8 @@ import Data.Text (pack)
 import Control.Applicative ((<$>))
 #endif
 
-mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
+mkRouteAttrsInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
-mkRouteAttrsInstance = mkRouteAttrsInstance' []
+mkRouteAttrsInstance cxt typ ress = do
-
-mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
-mkRouteAttrsInstance' cxt typ ress = do
     clauses <- mapM (goTree id) ress
     return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)
         [ FunD 'routeAttrs $ concat clauses

yesod-core/test/Hierarchy.hs

@@ -113,9 +113,9 @@ do
 --  /#Int TrailingIntR GET
 |]
 
-    rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
+    rrinst <- mkRenderRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
-    rainst <- mkRouteAttrsInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
+    rainst <- mkRouteAttrsInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
-    prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
+    prinst <- mkParseRouteInstance [] (ConT ''Hierarchy) $ map (fmap parseType) resources
     dispatch <- mkDispatchClause MkDispatchSettings
         { mdsRunHandler = [|runHandler|]
         , mdsSubDispatcher = [|subDispatch|]

yesod-core/test/RouteSpec.hs

@@ -72,9 +72,9 @@ do
             [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"] True
             ]
         ress = resParent : resLeaves
-    rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
+    rrinst <- mkRenderRouteInstance [] (ConT ''MyApp) ress
-    rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress
+    rainst <- mkRouteAttrsInstance [] (ConT ''MyApp) ress
-    prinst <- mkParseRouteInstance (ConT ''MyApp) ress
+    prinst <- mkParseRouteInstance [] (ConT ''MyApp) ress
     dispatch <- mkDispatchClause MkDispatchSettings
         { mdsRunHandler = [|runHandler|]
         , mdsSubDispatcher = [|subDispatch dispatcher|]