Changes reflecting web-routes-quasi modifications.

Minimal changes to get hello world working.

Yesod.hs

@@ -13,7 +13,6 @@ module Yesod
     , module Yesod.Formable
     , Application
     , liftIO
-    , Routes
     ) where
 
 #if TEST
@@ -34,4 +33,3 @@ import Yesod.Handler hiding (runHandler)
 import Network.Wai (Application)
 import Yesod.Hamlet
 import "transformers" Control.Monad.IO.Class (liftIO)
-import Web.Routes.Quasi (Routes)

Yesod/Dispatch.hs

@@ -18,7 +18,6 @@ module Yesod.Dispatch
     , basicHandler
       -- * Utilities
     , fullRender
-    , quasiRender
 #if TEST
     , testSuite
 #endif
@@ -30,6 +29,9 @@ import Yesod.Request
 import Yesod.Internal
 
 import Web.Routes.Quasi
+import Web.Routes.Quasi.Parse
+import Web.Routes.Quasi.TH
+import Web.Routes.Site
 import Language.Haskell.TH.Syntax
 
 import qualified Network.Wai as W
@@ -102,7 +104,7 @@ mkYesodData :: String -> [Resource] -> Q [Dec]
 mkYesodData name res = do
     (x, _) <- mkYesodGeneral name [] [] False res
     let rname = mkName $ "resources" ++ name
-    eres <- liftResources res
+    eres <- lift res
     let y = [ SigD rname $ ListT `AppT` ConT ''Resource
             , FunD rname [Clause [] (NormalB eres) []]
             ]
@@ -142,6 +144,32 @@ mkYesodGeneral name args clazzes isSub res = do
                  $ map (\x -> (x, [])) ("master" : args) ++
                    clazzes
     explode <- [|explodeHandler|]
+    let th = map thResourceFromResource res
+    w' <- createRoutes th
+    let w = DataD [] (mkName $ name ++ "Routes") [] w' []
+    let x = TySynInstD ''Routes [arg] $ ConT $ mkName $ name ++ "Routes"
+
+    parse' <- createParse th
+    parse'' <- newName "parse"
+    let parse = LetE [FunD parse'' parse'] $ VarE parse''
+
+    render' <- createRender th
+    render'' <- newName "render"
+    let render = LetE [FunD render'' render'] $ VarE render''
+
+    id' <- [|id|]
+    modMaster <- [|fmap chooseRep|]
+    dispatch' <- createDispatch modMaster id' th
+    dispatch'' <- newName "dispatch"
+    let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch''
+
+    site <- [|Site|]
+    let site' = site `AppE` dispatch `AppE` render `AppE` parse
+    let y = InstanceD [] (ConT ''YesodSite `AppT` arg)
+                [ FunD (mkName "getSite") [Clause [] (NormalB site') []]
+                ]
+    let z = undefined
+    {-
     QuasiSiteDecs w x y z <- createQuasiSite QuasiSiteSettings
                 { crRoutes = mkName $ name ++ "Routes"
                 , crApplication = ConT ''YesodApp
@@ -153,7 +181,11 @@ mkYesodGeneral name args clazzes isSub res = do
                                 then Right clazzes'
                                 else Left (ConT name')
                 }
-    return ([w, x], (if isSub then id else (:) yes) [y, z])
+    -}
+    return ([w, x], [y])
+
+thResourceFromResource :: Resource -> THResource
+thResourceFromResource (Resource n ps (ByMethod ms)) = (n, Simple ps $ map fst ms)
 
 compact :: [(String, [a])] -> [(String, [a])]
 compact [] = []
@@ -193,41 +225,23 @@ toWaiApp' y segments env = do
         method = B.unpack $ W.methodToBS $ W.requestMethod env
         types = httpAccept env
         pathSegments = filter (not . null) segments
-        eurl = quasiParse site pathSegments
+        eurl = parsePathSegments site pathSegments
         render u = fromMaybe
-                    (fullRender (approot y) (quasiRender site) u)
+                    (fullRender (approot y) (formatPathSegments site) u)
                     (urlRenderOverride y u)
     rr <- parseWaiRequest env session'
     onRequest y rr
-    ya <-
+    let h =
-      case eurl of
+          case eurl of
-        Left _ -> return $ runHandler (errorHandler y NotFound)
+            Left _ -> errorHandler y NotFound
-                          render
+            Right url -> do
-                          Nothing
+                -- FIXME auth <- isAuthorized y url
-                          id
+                case handleSite site render url method of
-                          y
+                    Nothing -> errorHandler y $ BadMethod method
-                          id
+                    Just h' -> h'
-        Right url -> do
-            auth <- isAuthorized y url
-            case auth of
-                Nothing -> return $ quasiDispatch site
-                                render
-                                url
-                                id
-                                y
-                                id
-                                (badMethodApp method)
-                                method
-                Just msg ->
-                    return $ runHandler
-                                (errorHandler y $ PermissionDenied msg)
-                                render
-                                (Just url)
-                                id
-                                y
-                                id
     let eurl' = either (const Nothing) Just eurl
     let eh er = runHandler (errorHandler y er) render eurl' id y id
+    let ya = runHandler h render eurl' id y id
     (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types
     let sessionVal = encodeSession key' exp' host sessionFinal
     let hs' = AddCookie (clientSessionDuration y) sessionName
@@ -271,10 +285,6 @@ basicHandler port app = do
             SS.run port app
         Just _ -> CGI.run app
 
-badMethodApp :: String -> YesodApp
-badMethodApp m = YesodApp $ \eh req cts
-         -> unYesodApp (eh $ BadMethod m) eh req cts
-
 fixSegs :: [String] -> [String]
 fixSegs [] = []
 fixSegs [x]

Yesod/Formable.hs

@@ -38,7 +38,7 @@ import Yesod.Request
 import Yesod.Handler
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.State
-import Web.Routes.Quasi (Routes, SinglePiece)
+import Web.Routes.Quasi (SinglePiece)
 import Data.Int (Int64)
 
 sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b

Yesod/Hamlet.hs

@@ -17,7 +17,6 @@ module Yesod.Hamlet
 import Text.Hamlet
 import Yesod.Content
 import Yesod.Handler
-import Web.Routes.Quasi (Routes)
 
 -- | Content for a web page. By providing this datatype, we can easily create
 -- generic site templates, which would have the type signature:

Yesod/Handler.hs

@@ -63,13 +63,13 @@ module Yesod.Handler
       -- * Internal Yesod
     , runHandler
     , YesodApp (..)
+    , Routes
     ) where
 
 import Prelude hiding (catch)
 import Yesod.Request
 import Yesod.Content
 import Yesod.Internal
-import Web.Routes.Quasi (Routes)
 import Data.List (foldl', intercalate)
 import Data.Neither
 
@@ -81,7 +81,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.Reader
-import Control.Monad.CatchIO (MonadCatchIO)
+import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
 
 import System.IO
 import qualified Network.Wai as W
@@ -93,6 +93,8 @@ import Text.Hamlet
 import Numeric (showIntAtBase)
 import Data.Char (ord, chr)
 
+type family Routes a
+
 data HandlerData sub master = HandlerData
     { handlerRequest :: Request
     , handlerSub :: sub

Yesod/Yesod.hs

@@ -31,13 +31,13 @@ import qualified Web.ClientSession as CS
 import Data.Monoid (mempty)
 import Data.ByteString.UTF8 (toString)
 import Database.Persist
-
+import Web.Routes.Site (Site)
-import Web.Routes.Quasi (QuasiSite (..), Routes)
 
 -- | This class is automatically instantiated when you use the template haskell
 -- mkYesod function. You should never need to deal with it directly.
 class YesodSite y where
-    getSite :: QuasiSite YesodApp y y
+    getSite :: Site (Routes y) (Method -> Maybe (Handler y ChooseRep))
+type Method = String
 
 -- | Define settings for a Yesod applications. The only required setting is
 -- 'approot'; other than that, there are intelligent defaults.

helloworld.hs

@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes #-}
+import Yesod
+data HelloWorld = HelloWorld
+mkYesod "HelloWorld" [$parseRoutes|/ Home GET|]
+instance Yesod HelloWorld where approot _ = ""
+getHome = return $ RepPlain $ toContent "Hello World!"
+main = toWaiApp HelloWorld >>= basicHandler 3000