From 6e90c6188e0e5e0c460d2a84acca0e15557f3b21 Mon Sep 17 00:00:00 2001
From: Matt Brown <matt@softmechanics.net>
Date: Sat, 27 Nov 2010 17:07:41 -0800
Subject: [PATCH] new SubsiteGetter class to support either pure (master ->
 sub) or impure (GHandler master master sub) versions of sub site lookup
 functions

---
 Yesod/Dispatch.hs | 16 +++++++++++++++-
 Yesod/Handler.hs  | 16 ++++++++++++++++
 2 files changed, 31 insertions(+), 1 deletion(-)

diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs
index e1db0723..3c691152 100644
--- a/Yesod/Dispatch.hs
+++ b/Yesod/Dispatch.hs
@@ -208,18 +208,32 @@ thResourceFromResource master (Resource n ps atts@[stype, toSubArg])
         let render = render' `AppE` gss'
         dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|]
         let dispatch = dispatch' `AppE` gss'
+        tmg <- mkToMasterArg ps toSubArg
         return (n, SubSite
             { ssType = ConT ''Route `AppT` stype'
             , ssParse = parse
             , ssRender = render
             , ssDispatch = dispatch
-            , ssToMasterArg = VarE $ mkName toSubArg
+            , ssToMasterArg = tmg
             , ssPieces = ps
             })
 
+
 thResourceFromResource _ (Resource n _ _) =
     error $ "Invalid attributes for resource: " ++ n
 
+mkToMasterArg :: [Piece] -> String -> Q Exp
+mkToMasterArg ps fname = do
+  let nargs = length $ filter (not.isStatic) ps
+      f = VarE $ mkName fname
+  args <- sequence $ take nargs $ repeat $ newName "x"
+  rsg <- [| runSubsiteGetter|]
+  let xps = map VarP args
+      xes = map VarE args
+      e' = foldl (\x y -> x `AppE` y) f xes
+      e = rsg `AppE` e'
+  return $ LamE xps e
+
 sessionName :: String
 sessionName = "_SESSION"
 
diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs
index 502f93d9..eb7db8a9 100644
--- a/Yesod/Handler.hs
+++ b/Yesod/Handler.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FunctionalDependencies #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -76,6 +77,7 @@ module Yesod.Handler
       -- * Internal Yesod
     , runHandler
     , YesodApp (..)
+    , SubsiteGetter(..)
     , toMasterHandler
     , toMasterHandlerDyn
     , toMasterHandlerMaybe
@@ -176,6 +178,20 @@ toMasterHandlerDyn tm getSub route (GHandler h) = do
     sub <- getSub
     GHandler $ withReaderT (handlerSubData tm (const sub) route) h
 
+class SubsiteGetter g m s | g -> s where
+  runSubsiteGetter :: g -> m s
+
+instance (master ~ master'
+         ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where
+  runSubsiteGetter get = do 
+    y <- getYesod
+    return $ get y
+
+instance (anySub ~ anySub'
+         ,master ~ master'
+         ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where
+  runSubsiteGetter = id
+
 toMasterHandlerMaybe :: (Route sub -> Route master)
                      -> (master -> sub)
                      -> Maybe (Route sub)