Merge pull request #1055 from Daniel-Diaz/master

mkYesodGeneral: Argument types can now be polymorphic

yesod-core/Yesod/Core/Dispatch.hs

@@ -11,6 +11,7 @@ module Yesod.Core.Dispatch
     , parseRoutesFile
     , parseRoutesFileNoCheck
     , mkYesod
+    , mkYesodWith
       -- ** More fine-grained
     , mkYesodData
     , mkYesodSubData

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)
@@ -15,6 +16,8 @@ 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
@@ -31,6 +34,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
@@ -44,30 +53,61 @@ 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]
 mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False
 
 -- | 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
-    , TySynD (mkName "Widget")  []
+    , TySynD (mkName "Widget")  (fmap PlainTV vs)
       $ 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
+               -> [Either String [String]] -- ^ arguments for the type
-               -> Bool                     -- ^ it this a subsite
+               -> Bool                     -- ^ is this a subsite
                -> [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
+        (mtys,ptys) = 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,n:ns,cs) ->
+                   case arg of
+                     Left  t  -> ( ConT (mkName t):xs, n:ns, cs )
+                     Right ts -> ( 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
+        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
@@ -80,11 +120,9 @@ 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)
-  where site    = foldl' AppT (ConT $ mkName name) (map (VarT . mkName) args)
-        res     = map (fmap parseType) resS
 
 mkMDS :: Q Exp -> MkDispatchSettings
 mkMDS rh = MkDispatchSettings
@@ -112,12 +150,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