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

Merge pull request #1478 from jprider63/master

Browse Source 
Update `mkYesodWith` and refactor so that `mkYesod` uses the context parser
This commit is contained in:
Michael Snoyman 2018-01-29 14:57:44 +02:00 committed by GitHub
commit fe233dd958
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 45 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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
-> [Either String [String]]
{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-}
-- | 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]
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' (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
-- 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.
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)) $
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 =
@ -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

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

@ -72,9 +72,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|]