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

Change mkYesodWith to accept separate lists for contexts and type

Browse Source 
arguments
This commit is contained in:
James Parker 2018-01-22 00:19:04 -05:00
parent e2b0a5c454
commit 18910b516b
6 changed files with 27 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
yesod-core/Yesod/Core/Internal/TH.hs
View File

@ -44,11 +44,13 @@ mkYesod :: String -- ^ name of the argument datatype
-> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return
mkYesodWith :: String
-> [Either String [String]]
{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name. (https://github.com/yesodweb/yesod/pull/1366)" #-}
mkYesodWith :: [[String]]
-> String
-> [String]
-> [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
@ -65,7 +67,7 @@ mkYesodDataGeneral name isSub res = 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
fst <$> mkYesodGeneral' cxt name' rest isSub return res
where
parseName = do
@ -114,7 +116,7 @@ masterTypeSyns vs site =
-- 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
-> [String] -- ^ arguments for the type
-> Bool -- ^ is this a subsite
-> (Exp -> Q Exp) -- ^ unwrap handler
-> [ResourceTree String]
@ -123,12 +125,12 @@ 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
@ -151,36 +153,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)) $
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
let argtypes = fmap nameToType mtys ++ fmap VarT vns
site = foldl' AppT (ConT name) argtypes
res = map (fmap (parseType . dropBracket)) resS
renderRouteDec <- mkRenderRouteInstance' appCxt site res
routeAttrsDec <- mkRouteAttrsInstance' appCxt site res
dispatchDec <- mkDispatchInstance site cxt f res
parseRoute <- mkParseRouteInstance' appCxt site res
renderRouteDec <- mkRenderRouteInstance appCxt site res
routeAttrsDec <- mkRouteAttrsInstance appCxt site res
dispatchDec <- mkDispatchInstance site appCxt f res
parseRoute <- mkParseRouteInstance appCxt site res
let rname = mkName $ "resources" ++ namestr
eres <- lift resS
let resourcesDec =

8
yesod-core/Yesod/Routes/TH/ParseRoute.hs
View File

@ -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 = mkParseRouteInstance' []
mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
mkParseRouteInstance' cxt typ ress = do
mkParseRouteInstance :: Cxt -> Type -> [ResourceTree a] -> Q Dec
mkParseRouteInstance cxt typ ress = do
cls <- mkDispatchClause
MkDispatchSettings
{ mdsRunHandler = [|\_ _ x _ -> x|]

11
yesod-core/Yesod/Routes/TH/RenderRoute.hs
View File

@ -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 = mkRenderRouteInstance' []
-- | A more general version of 'mkRenderRouteInstance' which takes an
-- additional context.
mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance' cxt typ ress = do
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)

8
yesod-core/Yesod/Routes/TH/RouteAttrs.hs
View File

@ -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 = mkRouteAttrsInstance' []
mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
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

6
yesod-core/test/Hierarchy.hs
View File

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

6
yesod-core/test/RouteSpec.hs
View File

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