Provide contexts for instances. Use standalone deriving when using

contexts.
jprider63 · Mar 24, 2017 · f5376ef · f5376ef
1 parent deb72b3
commit f5376ef
Show file tree

Hide file tree

Showing 4 changed files with 37 additions and 13 deletions.
diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs
@@ -81,7 +81,16 @@ mkYesodGeneral :: String                    -- ^ foundation type
                -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral namestr args isSub f resS = do
+mkYesodGeneral = mkYesodGeneral' []
+
+mkYesodGeneral' :: Cxt                      -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances.
+               -> 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' appCxt namestr args isSub f resS = do
     mname <- lookupTypeName namestr
     arity <- case mname of
                Just name -> do
@@ -125,10 +134,10 @@ mkYesodGeneral namestr args isSub f resS = do
                  ) ([],vns,[]) args
         site = foldl' AppT (ConT name) argtypes
         res = map (fmap parseType) resS
-    renderRouteDec <- mkRenderRouteInstance site res
-    routeAttrsDec  <- mkRouteAttrsInstance site res
+    renderRouteDec <- mkRenderRouteInstance' appCxt site res
+    routeAttrsDec  <- mkRouteAttrsInstance' appCxt site res
     dispatchDec    <- mkDispatchInstance site cxt f res
-    parse <- mkParseRouteInstance site res
+    parse <- mkParseRouteInstance' appCxt site res
     let rname = mkName $ "resources" ++ namestr
     eres <- lift resS
     let resourcesDec =

diff --git a/yesod-core/Yesod/Routes/TH/ParseRoute.hs b/yesod-core/Yesod/Routes/TH/ParseRoute.hs
@@ -3,6 +3,7 @@
 module Yesod.Routes.TH.ParseRoute
     ( -- ** ParseRoute
       mkParseRouteInstance
+    , mkParseRouteInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -12,7 +13,10 @@ import Yesod.Routes.Class
 import Yesod.Routes.TH.Dispatch
 
 mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
-mkParseRouteInstance typ ress = do
+mkParseRouteInstance = mkParseRouteInstance' []
+
+mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkParseRouteInstance' cxt typ ress = do
     cls <- mkDispatchClause
         MkDispatchSettings
             { mdsRunHandler = [|\_ _ x _ -> x|]
@@ -28,7 +32,7 @@ mkParseRouteInstance typ ress = do
         (map removeMethods ress)
     helper <- newName "helper"
     fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]
-    return $ instanceD [] (ConT ''ParseRoute `AppT` typ)
+    return $ instanceD cxt (ConT ''ParseRoute `AppT` typ)
         [ FunD 'parseRoute $ return $ Clause
             []
             (NormalB $ fixer `AppE` VarE helper)

diff --git a/yesod-core/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/Yesod/Routes/TH/RenderRoute.hs
@@ -3,6 +3,7 @@ module Yesod.Routes.TH.RenderRoute
     ( -- ** RenderRoute
       mkRenderRouteInstance
     , mkRenderRouteInstance'
+    , mkRenderRouteInstance'
     , mkRouteCons
     , mkRenderRouteClauses
     ) where
@@ -12,6 +13,7 @@ import Yesod.Routes.TH.Types
 import Language.Haskell.TH (conT)
 #endif
 import Language.Haskell.TH.Syntax
+import Data.Bits (xor)
 import Data.Maybe (maybeToList)
 import Control.Monad (replicateM)
 import Data.Text (pack)
@@ -156,18 +158,23 @@ mkRenderRouteInstance' cxt typ ress = do
     cls <- mkRenderRouteClauses ress
     (cons, decs) <- mkRouteCons ress
 #if MIN_VERSION_template_haskell(2,12,0)
-    did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT clazzes)
+    did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False))
 #elif MIN_VERSION_template_haskell(2,11,0)
-    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes
+    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False)
 #else
-    let did = DataInstD [] ''Route [typ] cons clazzes
+    let did = DataInstD [] ''Route [typ] cons (clazzes False)
 #endif
+    let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True)
     return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)
         [ did
         , FunD (mkName "renderRoute") cls
-        ] : decs
+        ]
+        : sds ++ decs
   where
-    clazzes = [''Show, ''Eq, ''Read]
+    clazzes standalone = if standalone `xor` null cxt then
+          [''Show, ''Eq, ''Read]
+        else
+          []
 
 #if MIN_VERSION_template_haskell(2,11,0)
 notStrict :: Bang

diff --git a/yesod-core/Yesod/Routes/TH/RouteAttrs.hs b/yesod-core/Yesod/Routes/TH/RouteAttrs.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Routes.TH.RouteAttrs
     ( mkRouteAttrsInstance
+    , mkRouteAttrsInstance'
     ) where
 
 import Yesod.Routes.TH.Types
@@ -15,9 +16,12 @@ import Control.Applicative ((<$>))
 #endif
 
 mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
-mkRouteAttrsInstance typ ress = do
+mkRouteAttrsInstance = mkRouteAttrsInstance' []
+
+mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec
+mkRouteAttrsInstance' cxt typ ress = do
     clauses <- mapM (goTree id) ress
-    return $ instanceD [] (ConT ''RouteAttrs `AppT` typ)
+    return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ)
         [ FunD 'routeAttrs $ concat clauses
         ]