101 lines
3.4 KiB
Haskell
101 lines
3.4 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
module Yesod.Routes.TH.Dispatch
|
|
( -- ** Dispatch
|
|
mkDispatchClause
|
|
) where
|
|
|
|
import Yesod.Routes.TH.Types
|
|
import Language.Haskell.TH.Syntax
|
|
import Data.Maybe (maybeToList, catMaybes)
|
|
import Control.Monad (replicateM)
|
|
import Data.Text (pack)
|
|
import qualified Yesod.Routes.Dispatch as D
|
|
import qualified Data.Map as Map
|
|
import Data.Char (toLower)
|
|
import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
|
|
import Yesod.Routes.Class
|
|
|
|
mkDispatchClause :: [Resource]
|
|
-> Q Clause
|
|
mkDispatchClause ress = do
|
|
u <- [|error "mkDispatchClause"|]
|
|
return $ Clause [] (NormalB u) []
|
|
{- FIXME
|
|
let routes = fmap ListE $ mapM toRoute ress
|
|
sub <- newName "sub"
|
|
mkey <- newName "mkey"
|
|
ts <- newName "ts"
|
|
master <- newName "master"
|
|
toMaster <- newName "toMaster"
|
|
let pats =
|
|
[ VarP sub
|
|
, VarP mkey
|
|
, VarP ts
|
|
, VarP master
|
|
, VarP toMaster
|
|
]
|
|
|
|
dispatch <- newName "dispatch"
|
|
body <- [|D.toDispatch $(routes)|]
|
|
return $ Clause
|
|
pats
|
|
(NormalB $ VarE dispatch `AppE` VarE ts `AppE` TupE (map VarE [sub, mkey, master, toMaster]))
|
|
[FunD dispatch [Clause [] (NormalB body) []]]
|
|
where
|
|
|
|
mkTsPattern :: [Piece] -> Maybe t -> Q ([Name], Maybe Name, Pat)
|
|
mkTsPattern pieces mmulti = do
|
|
end <-
|
|
case mmulti of
|
|
Nothing -> return (Nothing, ConP (mkName "[]") [])
|
|
Just{} -> do
|
|
end <- newName "end"
|
|
return (Just end, VarP end)
|
|
pieces' <- mapM go pieces
|
|
return (catMaybes $ map fst pieces', fst end, foldr (flip InfixP $ mkName ":") (snd end) $ map snd pieces')
|
|
where
|
|
go Static{} = return (Nothing, WildP)
|
|
go Dynamic{} = do
|
|
dyn <- newName "dyn"
|
|
return (Just dyn, VarP dyn)
|
|
|
|
-- | Convert a 'Piece' into a 'D.Piece'.
|
|
toPiece :: Piece -> Q Exp
|
|
toPiece (Static s) = [|D.Static $ pack $(lift s)|]
|
|
toPiece Dynamic{} = [|D.Dynamic|]
|
|
|
|
-- | Convert a 'Resource' into a 'D.Route'.
|
|
toRoute :: Resource -> Q Exp
|
|
toRoute res = do
|
|
let ps = fmap ListE $ mapM toPiece $ resourcePieces res
|
|
let m = maybe [|False|] (const [|True|]) $ resourceMulti res
|
|
case resourceDispatch res of
|
|
Methods mmulti mds -> do
|
|
let toPair m' = do
|
|
key <- [|pack $(lift m')|]
|
|
let value = VarE $ mkName $ map toLower m' ++ resourceName res
|
|
return $ TupE [key, value]
|
|
let handler =
|
|
if null mds
|
|
then [|Left $(return $ VarE $ mkName $ "handle" ++ resourceName res)|]
|
|
else [|Right $ Map.fromList $(fmap ListE $ mapM toPair mds)|]
|
|
sub <- newName "sub"
|
|
mkey <- newName "mkey"
|
|
(dyns, mend, tsPattern) <- mkTsPattern (resourcePieces res) mmulti
|
|
master <- newName "master"
|
|
toMaster <- newName "toMaster"
|
|
body <- [|$(toApp) $(handler)|]
|
|
let func = LamE
|
|
[ tsPattern
|
|
, TupP
|
|
[ VarP sub
|
|
, VarP mkey
|
|
, VarP master
|
|
, VarP toMaster
|
|
]
|
|
]
|
|
body
|
|
[|D.Route $(ps) $(m) $(return func)|]
|
|
Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME
|
|
-}
|