Switch yesod-core to use simpler dispatch
This commit is contained in:
parent
750bc9c9ac
commit
c19088d569
@ -17,6 +17,7 @@ import Data.ByteString.Lazy.Char8 ()
|
|||||||
import Data.List (foldl')
|
import Data.List (foldl')
|
||||||
|
|
||||||
import Yesod.Routes.TH
|
import Yesod.Routes.TH
|
||||||
|
import Yesod.Routes.TH.Simple (mkSimpleDispatchClause)
|
||||||
import Yesod.Routes.Parse
|
import Yesod.Routes.Parse
|
||||||
import Yesod.Core.Types
|
import Yesod.Core.Types
|
||||||
import Yesod.Core.Content
|
import Yesod.Core.Content
|
||||||
@ -115,7 +116,7 @@ mkDispatchInstance :: Type -- ^ The master site type
|
|||||||
-> [ResourceTree a] -- ^ The resource
|
-> [ResourceTree a] -- ^ The resource
|
||||||
-> DecsQ
|
-> DecsQ
|
||||||
mkDispatchInstance master res = do
|
mkDispatchInstance master res = do
|
||||||
clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res
|
clause' <- mkSimpleDispatchClause (mkMDS [|yesodRunner|]) res
|
||||||
let thisDispatch = FunD 'yesodDispatch [clause']
|
let thisDispatch = FunD 'yesodDispatch [clause']
|
||||||
return [InstanceD [] yDispatch [thisDispatch]]
|
return [InstanceD [] yDispatch [thisDispatch]]
|
||||||
where
|
where
|
||||||
@ -123,7 +124,7 @@ mkDispatchInstance master res = do
|
|||||||
|
|
||||||
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
|
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
|
||||||
mkYesodSubDispatch res = do
|
mkYesodSubDispatch res = do
|
||||||
clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
|
clause' <- mkSimpleDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
|
||||||
inner <- newName "inner"
|
inner <- newName "inner"
|
||||||
let innerFun = FunD inner [clause']
|
let innerFun = FunD inner [clause']
|
||||||
helper <- newName "helper"
|
helper <- newName "helper"
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||||
module YesodCoreTest.CleanPath (cleanPathTest, Widget) where
|
module YesodCoreTest.CleanPath (cleanPathTest, Widget) where
|
||||||
|
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
|
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}
|
||||||
module YesodCoreTest.Json (specs, Widget) where
|
module YesodCoreTest.Json (specs, Widget) where
|
||||||
|
|
||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||||
module YesodCoreTest.Links (linksTest, Widget) where
|
module YesodCoreTest.Links (linksTest, Widget) where
|
||||||
|
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
module YesodCoreTest.Media (mediaTest, Widget) where
|
module YesodCoreTest.Media (mediaTest, Widget) where
|
||||||
|
|
||||||
|
|||||||
@ -1,5 +1,6 @@
|
|||||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!!
|
||||||
module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where
|
module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where
|
||||||
|
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
|
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}
|
||||||
module YesodCoreTest.Reps (specs, Widget) where
|
module YesodCoreTest.Reps (specs, Widget) where
|
||||||
|
|
||||||
import Yesod.Core
|
import Yesod.Core
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
|
||||||
module YesodCoreTest.Widget (widgetTest) where
|
module YesodCoreTest.Widget (widgetTest) where
|
||||||
|
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: yesod-core
|
name: yesod-core
|
||||||
version: 1.2.6.7
|
version: 1.2.7
|
||||||
license: MIT
|
license: MIT
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman <michael@snoyman.com>
|
author: Michael Snoyman <michael@snoyman.com>
|
||||||
|
|||||||
@ -19,6 +19,10 @@ data SDC = SDC
|
|||||||
, reqExp :: Exp
|
, reqExp :: Exp
|
||||||
}
|
}
|
||||||
|
|
||||||
|
-- | A simpler version of Yesod.Routes.TH.Dispatch.mkDispatchClause, based on
|
||||||
|
-- view patterns.
|
||||||
|
--
|
||||||
|
-- Since 1.2.1
|
||||||
mkSimpleDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause
|
mkSimpleDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause
|
||||||
mkSimpleDispatchClause MkDispatchSettings {..} resources = do
|
mkSimpleDispatchClause MkDispatchSettings {..} resources = do
|
||||||
envName <- newName "env"
|
envName <- newName "env"
|
||||||
@ -159,7 +163,6 @@ mkSimpleDispatchClause MkDispatchSettings {..} resources = do
|
|||||||
let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp
|
let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp
|
||||||
route' = foldl' AppE (ConE (mkName name)) dyns
|
route' = foldl' AppE (ConE (mkName name)) dyns
|
||||||
route = foldr AppE route' extraCons
|
route = foldr AppE route' extraCons
|
||||||
getEnv = LitE $ StringL "FIXME2"
|
|
||||||
exp = subDispatcherE
|
exp = subDispatcherE
|
||||||
`AppE` runHandlerE
|
`AppE` runHandlerE
|
||||||
`AppE` sub2
|
`AppE` sub2
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user