diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 51ccbefb..2ebb3b01 100644 --- a/Yesod/Dispatch.hs +++ b/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 - => GHandler sub master c - -> (Routes master -> String) - -> Routes sub - -> (Routes sub -> Routes master) - -> master - -> (master -> sub) - -> YesodApp - -> String - -> YesodApp -explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f +typeHelper :: String -> Type +typeHelper = + foldl1 AppT . map go . words + where + go s@(x:_) + | isLower x = VarT $ mkName s + | otherwise = ConT $ mkName s 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 gsbod = NormalB $ VarE site - let yes' = FunD (mkName "getSite") [Clause [] gsbod []] - let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] - let clazzes' = compact - $ map (\x -> (x, [])) ("master" : args) ++ - clazzes - explode <- [|explodeHandler|] - let th = map thResourceFromResource res + let clazzes' = map (\(x, y) -> ClassP x [typeHelper y]) + $ concatMap (\(x, y) -> zip y $ repeat x) + $ compact + $ map (\x -> (x, [])) ("master" : args) ++ clazzes + th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites 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) - [ FunD (mkName "getSite") [Clause [] (NormalB site') []] + let (ctx, ytyp, yfunc) = + 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 - {- - 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]) + return ([w], [y]) -thResourceFromResource :: Resource -> THResource -thResourceFromResource (Resource n ps (ByMethod ms)) = (n, Simple ps $ map fst ms) +isStatic :: Piece -> Bool +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 [] = [] diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index e15966bb..925d4ac4 100644 --- a/Yesod/Handler.hs +++ b/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. diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index baca47f5..cb55cd41 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -22,8 +22,7 @@ module Yesod.Helpers.Auth ( -- * Subsite Auth (..) - , AuthRoutes (..) - , siteAuth + , Routes (..) -- * Settings , YesodAuth (..) , Creds (..) diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 8ad82c5e..7964790a 100644 --- a/Yesod/Helpers/Crud.hs +++ b/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 diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index fe4a283f..8a496bdb 100644 --- a/Yesod/Helpers/Static.hs +++ b/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 (..) - , siteStatic + , Routes (..) -- * 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') [] ] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 870fb3a8..e59856f3 100644 --- a/Yesod/Yesod.hs +++ b/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 diff --git a/yesod.cabal b/yesod.cabal index 564fbf96..890e7af0 100644 --- a/yesod.cabal +++ b/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,