From c875c949fe3e4ae9b5a41570bcf56ab07914a068 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 20 Apr 2010 08:52:19 -0700
Subject: [PATCH] Initial port to QuasiSite, rather rough

---
 Yesod/Handler.hs  | 10 +++++++---
 Yesod/Resource.hs |  4 ++--
 Yesod/Yesod.hs    | 24 +++++++++++++++---------
 3 files changed, 24 insertions(+), 14 deletions(-)

diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs
index 995e9fdc..a6a14f76 100644
--- a/Yesod/Handler.hs
+++ b/Yesod/Handler.hs
@@ -147,11 +147,15 @@ getRouteMaster = do
 
 runHandlerSub' :: HasReps c
                => GHandler sub master c
-               -> (master, master -> sub, Routes sub -> Routes master, Routes master -> String)
+               -> (Routes master -> String)
                -> Routes sub
-               -> (Routes sub -> String)
+               -> (Routes sub -> Routes master)
+               -> master
+               -> (master -> sub)
+               -> String
                -> YesodApp
-runHandlerSub' handler arg route render = runHandlerSub handler arg (Just route) render
+runHandlerSub' handler mrender surl tomurl marg tosarg _method =
+    runHandlerSub handler (marg, tosarg, tomurl, mrender) (Just surl) (mrender . tomurl)
 
 runHandlerSub :: HasReps c
               => GHandler sub master c
diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs
index 046107d3..67453d5c 100644
--- a/Yesod/Resource.hs
+++ b/Yesod/Resource.hs
@@ -27,7 +27,7 @@ mkYesod name res = do
                 , crResources = res
                 , crSite = site
                 }
-    return [tySyn, yes, x, y, z]
+    return [tySyn, yes, x, {-y, -}z]
 
 mkYesodSub :: String -> [Name] -> [Resource] -> Q [Dec]
 mkYesodSub name ctxs res = do
@@ -55,4 +55,4 @@ mkYesodSub name ctxs res = do
     let helper claz = ClassP claz [VarT man]
     let ctxs' = map helper ctxs
     let y' = ForallT [PlainTV man] ctxs' y
-    return [tySyn, x, SigD yname y', z]
+    return [tySyn, x, {-SigD yname y',-} z]
diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs
index 6762dfc5..30df8353 100644
--- a/Yesod/Yesod.hs
+++ b/Yesod/Yesod.hs
@@ -23,6 +23,7 @@ import Data.Maybe (fromMaybe)
 import Web.Mime
 import Web.Encodings (parseHttpAccept)
 import Web.Routes (Site (..), encodePathInfo, decodePathInfo)
+import Web.Routes.Quasi (QuasiSite (..))
 import Data.List (intercalate)
 
 import qualified Network.Wai as W
@@ -37,7 +38,7 @@ import qualified Network.Wai.Handler.CGI as CGI
 import System.Environment (getEnvironment)
 
 class YesodSite y where
-    getSite :: Site (Routes y) (String -> YesodApp -> y -> YesodApp)
+    getSite :: QuasiSite YesodApp (Routes y) y (Routes master) master
 
 class YesodSite a => Yesod a where
     -- | The encryption key to be used for encrypting client sessions.
@@ -156,18 +157,23 @@ toWaiApp' y resource session env = do
         method = B8.unpack $ W.methodToBS $ W.requestMethod env
         types = httpAccept env
         pathSegments = filter (not . null) $ cleanupSegments resource
-        eurl = parsePathSegments site pathSegments
+        eurl = quasiParse site pathSegments
         render u = approot y ++ '/'
-                 : encodePathInfo (fixSegs $ formatPathSegments site u)
+                 : encodePathInfo (fixSegs $ quasiRender site u)
     rr <- parseWaiRequest env session
     onRequest y rr
-    print pathSegments
+    print pathSegments -- FIXME remove
     let ya = case eurl of
-                Left _ -> runHandler (errorHandler y NotFound) y Nothing render
-                Right url -> handleSite site render url method
-                                        (badMethod method) y
-    let url' = either (const Nothing) Just eurl
-    let eh er = runHandler (errorHandler y er) y url' render
+                Nothing -> runHandler (errorHandler y NotFound) y Nothing render
+                Just url -> quasiDispatch site
+                                render
+                                url
+                                id
+                                y
+                                id
+                                (badMethod method)
+                                method
+    let eh er = runHandler (errorHandler y er) y eurl render
     unYesodApp ya eh rr types >>= responseToWaiResponse
 
 cleanupSegments :: [B.ByteString] -> [String]