haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Allow building with template-haskell-2.18.0

Browse Source
This commit is contained in:
Ryan Scott 2022-03-22 20:29:50 +00:00 committed by Teo Camarasu
parent 48d05fd6ab
commit 9039df924d
3 changed files with 27 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
yesod-core/src/Yesod/Routes/TH/Dispatch.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}
module Yesod.Routes.TH.Dispatch module Yesod.Routes.TH.Dispatch
( MkDispatchSettings (..) ( MkDispatchSettings (..)
@ -73,7 +74,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
handlePiece (Static str) = return (LitP $ StringL str, Nothing) handlePiece (Static str) = return (LitP $ StringL str, Nothing)
handlePiece (Dynamic _) = do handlePiece (Dynamic _) = do
x <- newName "dyn" x <- newName "dyn"
let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x])
return (pat, Just $ VarE x) return (pat, Just $ VarE x)
handlePieces :: [Piece a] -> Q ([Pat], [Exp]) handlePieces :: [Piece a] -> Q ([Pat], [Exp])
@ -86,7 +87,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
mkPathPat final = mkPathPat final =
foldr addPat final foldr addPat final
where where
addPat x y = ConP '(:) [x, y] addPat x y = conPCompat '(:) [x, y]
go :: SDC -> ResourceTree a -> Q Clause go :: SDC -> ResourceTree a -> Q Clause
go sdc (ResourceParent name _check pieces children) = do go sdc (ResourceParent name _check pieces children) = do
@ -124,11 +125,11 @@ mkDispatchClause MkDispatchSettings {..} resources = do
Methods multi methods -> do Methods multi methods -> do
(finalPat, mfinalE) <- (finalPat, mfinalE) <-
case multi of case multi of
Nothing -> return (ConP '[] [], Nothing) Nothing -> return (conPCompat '[] [], Nothing)
Just _ -> do Just _ -> do
multiName <- newName "multi" multiName <- newName "multi"
let pat = ViewP (VarE 'fromPathMultiPiece) let pat = ViewP (VarE 'fromPathMultiPiece)
(ConP 'Just [VarP multiName]) (conPCompat 'Just [VarP multiName])
return (pat, Just $ VarE multiName) return (pat, Just $ VarE multiName)
let dynsMulti = let dynsMulti =
@ -200,3 +201,10 @@ mkDispatchClause MkDispatchSettings {..} resources = do
defaultGetHandler :: Maybe String -> String -> Q Exp defaultGetHandler :: Maybe String -> String -> Q Exp
defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s
defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s
conPCompat :: Name -> [Pat] -> Pat
conPCompat n pats = ConP n
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
pats

11
yesod-core/src/Yesod/Routes/TH/RenderRoute.hs
View File

@ -67,7 +67,7 @@ mkRenderRouteClauses =
let cnt = length $ filter isDynamic pieces let cnt = length $ filter isDynamic pieces
dyns <- replicateM cnt $ newName "dyn" dyns <- replicateM cnt $ newName "dyn"
child <- newName "child" child <- newName "child"
let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child]
pack' <- [|pack|] pack' <- [|pack|]
tsp <- [|toPathPiece|] tsp <- [|toPathPiece|]
@ -100,7 +100,7 @@ mkRenderRouteClauses =
case resourceDispatch res of case resourceDispatch res of
Subsite{} -> return <$> newName "sub" Subsite{} -> return <$> newName "sub"
_ -> return [] _ -> return []
let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub
pack' <- [|pack|] pack' <- [|pack|]
tsp <- [|toPathPiece|] tsp <- [|toPathPiece|]
@ -182,3 +182,10 @@ notStrict = Bang NoSourceUnpackedness NoSourceStrictness
instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD :: Cxt -> Type -> [Dec] -> Dec
instanceD = InstanceD Nothing instanceD = InstanceD Nothing
conPCompat :: Name -> [Pat] -> Pat
conPCompat n pats = ConP n
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
pats

7
yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Yesod.Routes.TH.RouteAttrs module Yesod.Routes.TH.RouteAttrs
@ -26,7 +27,11 @@ goTree front (ResourceParent name _check pieces trees) =
toIgnore = length $ filter isDynamic pieces toIgnore = length $ filter isDynamic pieces
isDynamic Dynamic{} = True isDynamic Dynamic{} = True
isDynamic Static{} = False isDynamic Static{} = False
front' = front . ConP (mkName name) . ignored front' = front . ConP (mkName name)
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
. ignored
goRes :: (Pat -> Pat) -> Resource a -> Q Clause goRes :: (Pat -> Pat) -> Resource a -> Q Clause
goRes front Resource {..} = goRes front Resource {..} =