Subsites working with new web-routes-quasi

2010-06-30 14:24:36 +03:00 · 2010-06-30 14:24:36 +03:00 · 0e6f32f4a6
commit 0e6f32f4a6
parent 2f17cda10d
7 changed files with 93 additions and 52 deletions
--- 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 [] = []
--- 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.
--- 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 (..)
--- 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
--- 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') []
                ]
--- 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
--- 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,