Subsites working with new web-routes-quasi

Yesod/Dispatch.hs

@@ -57,6 +57,7 @@ import Control.Monad
 import Data.Maybe
 import Web.ClientSession
 import qualified Web.ClientSession as CS
+import Data.Char (isLower)
 
 import Data.Serialize
 import qualified Data.Serialize as Ser
@@ -114,17 +115,13 @@ mkYesodData name res = do
 mkYesodDispatch :: String -> [Resource] -> Q [Dec]
 mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
 
-explodeHandler :: HasReps c
+typeHelper :: String -> Type
-               => GHandler sub master c
+typeHelper =
-               -> (Routes master -> String)
+    foldl1 AppT . map go . words
-               -> Routes sub
+  where
-               -> (Routes sub -> Routes master)
+    go s@(x:_)
-               -> master
+        | isLower x = VarT $ mkName s
-               -> (master -> sub)
+        | otherwise = ConT $ mkName s
-               -> YesodApp
-               -> String
-               -> YesodApp
-explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f
 
 mkYesodGeneral :: String -- ^ argument name
                -> [String] -- ^ parameters for site argument
@@ -136,18 +133,13 @@ mkYesodGeneral name args clazzes isSub res = do
     let name' = mkName name
         args' = map mkName args
         arg = foldl AppT (ConT name') $ map VarT args'
-    let site = mkName $ "site" ++ name
+    let clazzes' = map (\(x, y) -> ClassP x [typeHelper y])
-    let gsbod = NormalB $ VarE site
+                 $ concatMap (\(x, y) -> zip y $ repeat x)
-    let yes' = FunD (mkName "getSite") [Clause [] gsbod []]
+                 $ compact
-    let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes']
+                 $ map (\x -> (x, [])) ("master" : args) ++ clazzes
-    let clazzes' = compact
+    th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites
-                 $ map (\x -> (x, [])) ("master" : args) ++
-                   clazzes
-    explode <- [|explodeHandler|]
-    let th = map thResourceFromResource res
     w' <- createRoutes th
     let w = DataInstD [] ''Routes [arg] w' []
-    let x = TySynD (mkName $ name ++ "Routes") [] $ ConT ''Routes `AppT` arg
 
     parse' <- createParse th
     parse'' <- newName "parse"
@@ -157,35 +149,58 @@ mkYesodGeneral name args clazzes isSub res = do
     render'' <- newName "render"
     let render = LetE [FunD render'' render'] $ VarE render''
 
-    id' <- [|id|]
+    tmh <- [|toMasterHandler|]
     modMaster <- [|fmap chooseRep|]
-    dispatch' <- createDispatch modMaster id' th
+    dispatch' <- createDispatch modMaster tmh 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)
+    let (ctx, ytyp, yfunc) =
-                [ FunD (mkName "getSite") [Clause [] (NormalB site') []]
+            if isSub
+                then (clazzes', ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite")
+                else ([], ConT ''YesodSite `AppT` arg, "getSite")
+    let y = InstanceD ctx ytyp
+                [ FunD (mkName yfunc) [Clause [] (NormalB site') []]
                 ]
-    let z = undefined
+    return ([w], [y])
-    {-
-    QuasiSiteDecs w x y z <- createQuasiSite QuasiSiteSettings
-                { crRoutes = mkName $ name ++ "Routes"
-                , crApplication = ConT ''YesodApp
-                , crArgument = arg
-                , crExplode = explode
-                , crResources = res
-                , crSite = site
-                , crMaster = if isSub
-                                then Right clazzes'
-                                else Left (ConT name')
-                }
-    -}
-    return ([w, x], [y])
 
-thResourceFromResource :: Resource -> THResource
+isStatic :: Piece -> Bool
-thResourceFromResource (Resource n ps (ByMethod ms)) = (n, Simple ps $ map fst ms)
+isStatic StaticPiece{} = True
+isStatic _ = False
+
+fromStatic :: Piece -> String
+fromStatic (StaticPiece s) = s
+fromStatic _ = error "fromStatic"
+
+thResourceFromResource :: Type -> Resource -> Q THResource
+thResourceFromResource master (Resource n ps atts@[stype, toSubArg])
+    | all isStatic ps && any (any isLower) atts = do
+        let stype' = ConT $ mkName stype
+        gss <- [|getSubSite|]
+        let inside = ConT ''Maybe `AppT`
+                     (ConT ''GHandler `AppT` stype' `AppT` master `AppT`
+                      ConT ''ChooseRep)
+        let typ = ConT ''Site `AppT`
+                  (ConT ''Routes `AppT` stype') `AppT`
+                  (ArrowT `AppT` ConT ''String `AppT` inside)
+        let gss' = gss `SigE` typ
+        parse' <- [|parsePathSegments|]
+        let parse = parse' `AppE` gss'
+        render' <- [|formatPathSegments|]
+        let render = render' `AppE` gss'
+        dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|]
+        let dispatch = dispatch' `AppE` gss'
+        return (n, SubSite
+            { ssType = ConT ''Routes `AppT` stype'
+            , ssParse = parse
+            , ssRender = render
+            , ssDispatch = dispatch
+            , ssToMasterArg = VarE $ mkName toSubArg
+            , ssPieces = map fromStatic ps
+            })
+thResourceFromResource _ (Resource n ps attribs) = return (n, Simple ps attribs)
 
 compact :: [(String, [a])] -> [(String, [a])]
 compact [] = []

Yesod/Handler.hs

@@ -64,6 +64,7 @@ module Yesod.Handler
     , runHandler
     , YesodApp (..)
     , Routes
+    , toMasterHandler
     ) where
 
 import Prelude hiding (catch)
@@ -104,6 +105,25 @@ data HandlerData sub master = HandlerData
     , handlerToMaster :: Routes sub -> Routes master
     }
 
+handlerSubData :: (Routes sub -> Routes master)
+               -> (master -> sub)
+               -> Routes sub
+               -> HandlerData oldSub master
+               -> HandlerData sub master
+handlerSubData tm ts route hd = hd
+    { handlerSub = ts $ handlerMaster hd
+    , handlerToMaster = tm
+    , handlerRoute = Just route
+    }
+
+toMasterHandler :: (Routes sub -> Routes master)
+                -> (master -> sub)
+                -> Routes sub
+                -> GHandler sub master a
+                -> Handler master a
+toMasterHandler tm ts route (GHandler h) =
+    GHandler $ withReaderT (handlerSubData tm ts route) h
+
 -- | A generic handler monad, which can have a different subsite and master
 -- site. This monad is a combination of reader for basic arguments, a writer
 -- for headers, and an error-type monad for handling special responses.

Yesod/Helpers/Auth.hs

@@ -22,8 +22,7 @@
 module Yesod.Helpers.Auth
     ( -- * Subsite
       Auth (..)
-    , AuthRoutes (..)
+    , Routes (..)
-    , siteAuth
       -- * Settings
     , YesodAuth (..)
     , Creds (..)

Yesod/Helpers/Crud.hs

@@ -1,12 +1,13 @@
 {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE Rank2Types #-}
 module Yesod.Helpers.Crud
     ( Item (..)
     , Crud (..)
-    , CrudRoutes (..)
+    , Routes (..)
     , defaultCrud
-    , siteCrud
     ) where
 
 import Yesod.Yesod

Yesod/Helpers/Static.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Helpers.Static
@@ -25,8 +27,7 @@
 module Yesod.Helpers.Static
     ( -- * Subsite
       Static (..)
-    , StaticRoutes (..)
+    , Routes (..)
-    , siteStatic
       -- * Lookup files in filesystem
     , fileLookupDir
     , staticFiles
@@ -52,9 +53,9 @@ import Test.HUnit hiding (Test)
 -- see 'fileLookupDir'.
 data Static = Static (FilePath -> IO (Maybe (Either FilePath Content)))
 
-$(mkYesodSub "Static" [] [$parseRoutes|
+mkYesodSub "Static" [] [$parseRoutes|
 *Strings StaticRoute GET
-|])
+|]
 
 -- | Lookup files in a specific directory.
 --
@@ -117,7 +118,7 @@ staticFiles fp = do
         f' <- lift f
         let sr = ConE $ mkName "StaticRoute"
         return
-            [ SigD name $ ConT ''StaticRoutes
+            [ SigD name $ ConT ''Routes `AppT` ConT ''Static
             , FunD name
                 [ Clause [] (NormalB $ sr `AppE` f') []
                 ]

Yesod/Yesod.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 -- | The basic typeclass for a Yesod application.
 module Yesod.Yesod
     ( -- * Type classes
       Yesod (..)
     , YesodSite (..)
+    , YesodSubSite (..)
       -- ** Persistence
     , YesodPersist (..)
     , module Database.Persist
@@ -39,6 +41,9 @@ class YesodSite y where
     getSite :: Site (Routes y) (Method -> Maybe (Handler y ChooseRep))
 type Method = String
 
+class YesodSubSite s y where
+    getSubSite :: Site (Routes s) (Method -> Maybe (GHandler s y ChooseRep))
+
 -- | Define settings for a Yesod applications. The only required setting is
 -- 'approot'; other than that, there are intelligent defaults.
 class Yesod a where

yesod.cabal

@@ -31,7 +31,7 @@ library
                      utf8-string >= 0.3.4 && < 0.4,
                      template-haskell >= 2.4 && < 2.5,
                      web-routes >= 0.22 && < 0.23,
-                     web-routes-quasi >= 0.4 && < 0.5,
+                     web-routes-quasi >= 0.5 && < 0.6,
                      hamlet >= 0.3.1 && < 0.4,
                      transformers >= 0.2 && < 0.3,
                      clientsession >= 0.4.0 && < 0.5,