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

Allow Site types to have type parameters.

Browse Source
This commit is contained in:
Daniel Díaz 2015-08-06 00:35:48 +02:00
parent 9991e307e3
commit 366bfbd319
1 changed files with 12 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -52,11 +52,11 @@ mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False
-- | Get the Handler and Widget type synonyms for the given site. -- | Get the Handler and Widget type synonyms for the given site.
masterTypeSyns :: Type -> [Dec] masterTypeSyns :: [Name] -> Type -> [Dec]
masterTypeSyns site = masterTypeSyns vs site =
[ TySynD (mkName "Handler") [] [ TySynD (mkName "Handler") (fmap PlainTV vs)
$ ConT ''HandlerT `AppT` site `AppT` ConT ''IO $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
, TySynD (mkName "Widget") [] , TySynD (mkName "Widget") (fmap PlainTV vs)
$ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''() $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
] ]
@ -75,8 +75,13 @@ mkYesodGeneral name args isSub resS = do
NewtypeD _ _ vs _ _ -> length vs NewtypeD _ _ vs _ _ -> length vs
_ -> 0 _ -> 0
_ -> 0 _ -> 0
vs <- fmap (fmap VarT) $ replicateM arity $ newName "t" -- Generate as many variable names as the arity indicates
let site = foldl' AppT (foldl' AppT (ConT $ mkName name) vs) (map (VarT . mkName) args) vns <- replicateM arity $ newName "t"
-- Variables for type parameters
let vs = fmap VarT vns
-- Base type (site type with variables)
basety = foldl' AppT (ConT $ mkName name) vs
site = foldl' AppT basety (map (VarT . mkName) args)
res = map (fmap parseType) resS res = map (fmap parseType) resS
renderRouteDec <- mkRenderRouteInstance site res renderRouteDec <- mkRenderRouteInstance site res
routeAttrsDec <- mkRouteAttrsInstance site res routeAttrsDec <- mkRouteAttrsInstance site res
@ -93,7 +98,7 @@ mkYesodGeneral name args isSub resS = do
, renderRouteDec , renderRouteDec
, [routeAttrsDec] , [routeAttrsDec]
, resourcesDec , resourcesDec
, if isSub then [] else masterTypeSyns site , if isSub then [] else masterTypeSyns vns site
] ]
return (dataDec, dispatchDec) return (dataDec, dispatchDec)