From 9991e307e3ba3caa83d44fdfcc705e2b679676d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20D=C3=ADaz?= Date: Thu, 6 Aug 2015 00:13:28 +0200 Subject: [PATCH 1/5] Attempt to add support for parametrized types in mkYesod. --- yesod-core/Yesod/Core/Internal/TH.hs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 7e84c1cb..1a9fcf91 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -15,6 +15,7 @@ import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () import Data.List (foldl') +import Control.Monad (replicateM) import Yesod.Routes.TH import Yesod.Routes.Parse @@ -65,6 +66,18 @@ mkYesodGeneral :: String -- ^ foundation type -> [ResourceTree String] -> Q([Dec],[Dec]) mkYesodGeneral name args isSub resS = do + info <- reify $ mkName name + let arity = + case info of + TyConI dec -> + case dec of + DataD _ _ vs _ _ -> length vs + NewtypeD _ _ vs _ _ -> length vs + _ -> 0 + _ -> 0 + vs <- fmap (fmap VarT) $ replicateM arity $ newName "t" + let site = foldl' AppT (foldl' AppT (ConT $ mkName name) vs) (map (VarT . mkName) args) + res = map (fmap parseType) resS renderRouteDec <- mkRenderRouteInstance site res routeAttrsDec <- mkRouteAttrsInstance site res dispatchDec <- mkDispatchInstance site res @@ -83,8 +96,6 @@ mkYesodGeneral name args isSub resS = do , if isSub then [] else masterTypeSyns site ] return (dataDec, dispatchDec) - where site = foldl' AppT (ConT $ mkName name) (map (VarT . mkName) args) - res = map (fmap parseType) resS mkMDS :: Q Exp -> MkDispatchSettings mkMDS rh = MkDispatchSettings From 366bfbd319e482f91514db8b63b7ab86c56a3369 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20D=C3=ADaz?= Date: Thu, 6 Aug 2015 00:35:48 +0200 Subject: [PATCH 2/5] Allow Site types to have type parameters. --- yesod-core/Yesod/Core/Internal/TH.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 1a9fcf91..49f143ac 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -52,11 +52,11 @@ mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False -- | Get the Handler and Widget type synonyms for the given site. -masterTypeSyns :: Type -> [Dec] -masterTypeSyns site = - [ TySynD (mkName "Handler") [] +masterTypeSyns :: [Name] -> Type -> [Dec] +masterTypeSyns vs site = + [ TySynD (mkName "Handler") (fmap PlainTV vs) $ 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 ''() ] @@ -75,8 +75,13 @@ mkYesodGeneral name args isSub resS = do NewtypeD _ _ vs _ _ -> length vs _ -> 0 _ -> 0 - vs <- fmap (fmap VarT) $ replicateM arity $ newName "t" - let site = foldl' AppT (foldl' AppT (ConT $ mkName name) vs) (map (VarT . mkName) args) + -- Generate as many variable names as the arity indicates + 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 renderRouteDec <- mkRenderRouteInstance site res routeAttrsDec <- mkRouteAttrsInstance site res @@ -93,7 +98,7 @@ mkYesodGeneral name args isSub resS = do , renderRouteDec , [routeAttrsDec] , resourcesDec - , if isSub then [] else masterTypeSyns site + , if isSub then [] else masterTypeSyns vns site ] return (dataDec, dispatchDec) From ea62a38464eb4c22fa4d100f387bd22720d72b67 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20D=C3=ADaz?= Date: Mon, 10 Aug 2015 07:23:26 +0200 Subject: [PATCH 3/5] mkYesodGeneral arguments can now be monomorphic or polymorphic types. It is possible to impose class instances to polymorphic type arguments. --- yesod-core/Yesod/Core/Dispatch.hs | 1 + yesod-core/Yesod/Core/Internal/TH.hs | 38 ++++++++++++++++++++-------- 2 files changed, 28 insertions(+), 11 deletions(-) diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 92fd1224..36f99c72 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -11,6 +11,7 @@ module Yesod.Core.Dispatch , parseRoutesFile , parseRoutesFileNoCheck , mkYesod + , mkYesodWith -- ** More fine-grained , mkYesodData , mkYesodSubData diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 49f143ac..d118809d 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -16,6 +16,7 @@ import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () import Data.List (foldl') import Control.Monad (replicateM) +import Data.Either (partitionEithers) import Yesod.Routes.TH import Yesod.Routes.Parse @@ -32,6 +33,12 @@ mkYesod :: String -- ^ name of the argument datatype -> Q [Dec] mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False +mkYesodWith :: String + -> [Either String [String]] + -> [ResourceTree String] + -> Q [Dec] +mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False + -- | 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 @@ -45,7 +52,7 @@ mkYesodSubData name res = mkYesodDataGeneral name True res mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec] mkYesodDataGeneral name isSub res = do let (name':rest) = words name - fmap fst $ mkYesodGeneral name' rest isSub res + fmap fst $ mkYesodGeneral name' (fmap Left rest) isSub res -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] @@ -60,9 +67,12 @@ masterTypeSyns vs site = $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `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 - -> [String] -- ^ arguments for the type - -> Bool -- ^ it this a subsite + -> [Either String [String]] -- ^ arguments for the type + -> Bool -- ^ is this a subsite -> [ResourceTree String] -> Q([Dec],[Dec]) mkYesodGeneral name args isSub resS = do @@ -75,17 +85,22 @@ mkYesodGeneral name args isSub resS = do NewtypeD _ _ vs _ _ -> length vs _ -> 0 _ -> 0 + (mtys,ptys) = partitionEithers args -- Generate as many variable names as the arity indicates - vns <- replicateM arity $ newName "t" - -- Variables for type parameters - let vs = fmap VarT vns + vns <- replicateM (arity - length mtys) $ newName "t" -- Base type (site type with variables) - basety = foldl' AppT (ConT $ mkName name) vs - site = foldl' AppT basety (map (VarT . mkName) args) + let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $ + foldr (\arg (xs,n:ns,cs) -> + case arg of + Left t -> ( ConT (mkName t):xs, n:ns, cs ) + Right ts -> ( VarT n :xs, ns + , fmap (\t -> AppT (ConT $ mkName t) (VarT n)) ts ++ cs ) + ) ([],vns,[]) args + site = foldl' AppT (ConT $ mkName name) argtypes res = map (fmap parseType) resS renderRouteDec <- mkRenderRouteInstance site res routeAttrsDec <- mkRouteAttrsInstance site res - dispatchDec <- mkDispatchInstance site res + dispatchDec <- mkDispatchInstance site cxt res parse <- mkParseRouteInstance site res let rname = mkName $ "resources" ++ name eres <- lift resS @@ -128,12 +143,13 @@ mkMDS rh = MkDispatchSettings -- when writing library/plugin for yesod, this combinator becomes -- handy. mkDispatchInstance :: Type -- ^ The master site type + -> Cxt -- ^ Context of the instance -> [ResourceTree a] -- ^ The resource -> DecsQ -mkDispatchInstance master res = do +mkDispatchInstance master cxt res = do clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res let thisDispatch = FunD 'yesodDispatch [clause'] - return [InstanceD [] yDispatch [thisDispatch]] + return [InstanceD cxt yDispatch [thisDispatch]] where yDispatch = ConT ''YesodDispatch `AppT` master From 4897c24d3fab3c7fc6f278f64dfce8bde1970f02 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20D=C3=ADaz?= Date: Tue, 11 Aug 2015 22:07:28 +0200 Subject: [PATCH 4/5] Use CPP to adapt to template-haskell changes according to the version of base used. --- yesod-core/Yesod/Core/Internal/TH.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index d118809d..2fc1ea53 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} module Yesod.Core.Internal.TH where import Prelude hiding (exp) @@ -94,7 +95,13 @@ mkYesodGeneral name args isSub resS = do case arg of Left t -> ( ConT (mkName t):xs, n:ns, cs ) Right ts -> ( VarT n :xs, ns - , fmap (\t -> AppT (ConT $ mkName t) (VarT n)) ts ++ cs ) + , fmap (\t -> +#if MIN_VERSION_base(4,8,0) + AppT (ConT $ mkName t) (VarT n) +#else + ClassP (mkName t) [VarT n] +#endif + ) ts ++ cs ) ) ([],vns,[]) args site = foldl' AppT (ConT $ mkName name) argtypes res = map (fmap parseType) resS From 42ec7f53e987acbbe4c6ccb519964ee2d3d7aad4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20D=C3=ADaz?= Date: Tue, 11 Aug 2015 22:10:12 +0200 Subject: [PATCH 5/5] Depend directly on template-haskell. --- yesod-core/Yesod/Core/Internal/TH.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 2fc1ea53..22445c51 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -96,7 +96,7 @@ mkYesodGeneral name args isSub resS = do Left t -> ( ConT (mkName t):xs, n:ns, cs ) Right ts -> ( VarT n :xs, ns , fmap (\t -> -#if MIN_VERSION_base(4,8,0) +#if MIN_VERSION_template_haskell(2,10,0) AppT (ConT $ mkName t) (VarT n) #else ClassP (mkName t) [VarT n]