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

Don't rely on OverloadedStrings

Browse Source
This commit is contained in:
Michael Snoyman 2011-04-24 16:40:05 +03:00
parent 18e04175eb
commit 0d77804d0f
5 changed files with 103 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
Test/NoOverloadedStrings.hs Normal file
View File

@ -0,0 +1,50 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Test.NoOverloadedStrings (noOverloadedTest) where
import Yesod.Core hiding (Request)
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit
import Network.Wai.Test
import Network.Wai
import Data.Monoid (mempty)
import Data.String (fromString)
data Subsite = Subsite
getSubsite = const Subsite
mkYesodSub "Subsite" [] [parseRoutes|
/bar BarR GET
|]
getBarR :: GHandler Subsite m ()
getBarR = return ()
data Y = Y
mkYesod "Y" [parseRoutes|
/ RootR GET
/foo FooR GET
/subsite SubsiteR Subsite getSubsite
|]
instance Yesod Y where
approot _ = fromString ""
getRootR = return ()
getFooR = return ()
runner f = toWaiApp Y >>= runSession f
defaultRequest = Request
{ pathInfo = []
, requestHeaders = []
, queryString = []
, requestMethod = fromString "GET"
}
case_sanity = runner $ do
res <- request defaultRequest
assertBody mempty res
noOverloadedTest :: Test
noOverloadedTest = testGroup "Test.NoOverloadedStrings"
[ testCase "sanity" case_sanity
]

6
Yesod/Dispatch.hs
View File

@ -27,9 +27,9 @@ import Yesod.Internal.Core
import Yesod.Handler
import Yesod.Internal.Dispatch
import Web.Routes.Quasi
import Web.Routes.Quasi.Parse
import Web.Routes.Quasi.TH
import Web.Routes.Quasi (SinglePiece, MultiPiece, Strings)
import Web.Routes.Quasi.Parse (Resource (..), parseRoutes, parseRoutesFile)
import Web.Routes.Quasi.TH (THResource, Pieces (..), createRoutes, createRender)
import Language.Haskell.TH.Syntax
import qualified Network.Wai as W

63
Yesod/Internal/Dispatch.hs
View File

@ -24,6 +24,7 @@ import Data.Text (Text)
import Data.Monoid (mappend)
import qualified Blaze.ByteString.Builder
import qualified Data.ByteString.Char8 as S8
import qualified Data.Text
{-|
@ -155,21 +156,35 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met
let caseExp = rm `AppE` VarE req
yr <- [|yesodRunner|]
cr <- [|fmap chooseRep|]
pack <- [|Data.Text.pack|]
eq <- [|(==)|]
let url = foldl' AppE (ConE $ mkName constr) $ frontVars []
let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars [])
runHandler' h = NormalB $ yr `AppE` sub
`AppE` VarE master
`AppE` toMasterRoute
`AppE` VarE mkey
`AppE` (just `AppE` url)
`AppE` h
`AppE` VarE req
let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) []
let clauses =
case methods of
[] -> [Clause [VarP req] (runHandlerVars $ "handle" ++ constr) []]
_ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods ++
[Match WildP (runHandler' badMethod') []]) []]
runHandler' h = yr `AppE` sub
`AppE` VarE master
`AppE` toMasterRoute
`AppE` VarE mkey
`AppE` (just `AppE` url)
`AppE` h
`AppE` VarE req
let match :: String -> Q Match
match m = do
x <- newName "x"
return $ Match
(VarP x)
(GuardedB
[ ( NormalG $ InfixE (Just $ VarE x) eq (Just $ (LitE $ StringL m)) -- FIXME need to pack, right?
, runHandlerVars $ map toLower m ++ constr
)
])
[]
clauses <-
case methods of
[] -> return [Clause [VarP req] (NormalB $ runHandlerVars $ "handle" ++ constr) []]
_ -> do
matches <- mapM match methods
return [Clause [VarP req] (NormalB $ CaseE caseExp $ matches ++
[Match WildP (NormalB $ runHandler' badMethod') []]) []]
let exp = CaseE segments
[ Match
(ConP (mkName "[]") [])
@ -185,10 +200,17 @@ mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do
srest <- newName "segments"
innerExp <- mkSimpleExp (VarE srest) pieces frontVars x
nothing <- [|Nothing|]
y <- newName "y"
pack <- [|Data.Text.pack|]
eq <- [|(==)|]
let exp = CaseE segments
[ Match
(InfixP (LitP $ StringL s) (mkName ":") (VarP srest))
(NormalB innerExp)
(InfixP (VarP y) (mkName ":") (VarP srest))
(GuardedB
[ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
, innerExp
)
])
[]
, Match WildP (NormalB nothing) []
]
@ -260,10 +282,17 @@ mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do
srest <- newName "segments"
innerExp <- mkSubsiteExp srest pieces frontVars x
nothing <- [|Nothing|]
y <- newName "y"
pack <- [|Data.Text.pack|]
eq <- [|(==)|]
let exp = CaseE (VarE segments)
[ Match
(InfixP (LitP $ StringL s) (mkName ":") (VarP srest))
(NormalB innerExp)
(InfixP (VarP y) (mkName ":") (VarP srest))
(GuardedB
[ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
, innerExp
)
])
[]
, Match WildP (NormalB nothing) []
]

2
runtests.hs
View File

@ -4,6 +4,7 @@ import Test.Exceptions
import Test.Widget
import Test.Media
import Test.Links
import Test.NoOverloadedStrings
main :: IO ()
main = defaultMain
@ -12,4 +13,5 @@ main = defaultMain
, widgetTest
, mediaTest
, linksTest
, noOverloadedTest
]

4
yesod-core.cabal
View File

@ -1,5 +1,5 @@
name: yesod-core
version: 0.8.0
version: 0.8.0.1
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -33,7 +33,7 @@ library
, bytestring >= 0.9.1.4 && < 0.10
, text >= 0.5 && < 0.12
, template-haskell
, web-routes-quasi >= 0.7 && < 0.8
, web-routes-quasi >= 0.7.0.1 && < 0.8
, hamlet >= 0.8 && < 0.9
, blaze-builder >= 0.2.1 && < 0.4
, transformers >= 0.2 && < 0.3