diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index fbfee2ed..c7746948 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/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 - -> [Either String [String]] +{-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. " #-} +-- | 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 diff --git a/yesod-core/Yesod/Routes/TH/ParseRoute.hs b/yesod-core/Yesod/Routes/TH/ParseRoute.hs index f5ee972a..fc5535a7 100644 --- a/yesod-core/Yesod/Routes/TH/ParseRoute.hs +++ b/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 = 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|] diff --git a/yesod-core/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/Yesod/Routes/TH/RenderRoute.hs index 5177ef20..4da02e08 100644 --- a/yesod-core/Yesod/Routes/TH/RenderRoute.hs +++ b/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 = 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) diff --git a/yesod-core/Yesod/Routes/TH/RouteAttrs.hs b/yesod-core/Yesod/Routes/TH/RouteAttrs.hs index 0348206a..1b94af95 100644 --- a/yesod-core/Yesod/Routes/TH/RouteAttrs.hs +++ b/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 = 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 diff --git a/yesod-core/test/Hierarchy.hs b/yesod-core/test/Hierarchy.hs index c6994f46..1cb0817c 100644 --- a/yesod-core/test/Hierarchy.hs +++ b/yesod-core/test/Hierarchy.hs @@ -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|] diff --git a/yesod-core/test/RouteSpec.hs b/yesod-core/test/RouteSpec.hs index 5766a4cf..c5c7be66 100644 --- a/yesod-core/test/RouteSpec.hs +++ b/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 - 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|]