From 0d77804d0f2ca1065e6e9e1fd4e57a0630cc3277 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Apr 2011 16:40:05 +0300 Subject: [PATCH] Don't rely on OverloadedStrings --- Test/NoOverloadedStrings.hs | 50 +++++++++++++++++++++++++++++ Yesod/Dispatch.hs | 6 ++-- Yesod/Internal/Dispatch.hs | 63 +++++++++++++++++++++++++++---------- runtests.hs | 2 ++ yesod-core.cabal | 4 +-- 5 files changed, 103 insertions(+), 22 deletions(-) create mode 100644 Test/NoOverloadedStrings.hs diff --git a/Test/NoOverloadedStrings.hs b/Test/NoOverloadedStrings.hs new file mode 100644 index 00000000..dfd83120 --- /dev/null +++ b/Test/NoOverloadedStrings.hs @@ -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 + ] diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index e11cd817..bba979d6 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -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 diff --git a/Yesod/Internal/Dispatch.hs b/Yesod/Internal/Dispatch.hs index 48664bb0..b6275f74 100644 --- a/Yesod/Internal/Dispatch.hs +++ b/Yesod/Internal/Dispatch.hs @@ -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) [] ] diff --git a/runtests.hs b/runtests.hs index 631f1a90..0dfb7564 100644 --- a/runtests.hs +++ b/runtests.hs @@ -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 ] diff --git a/yesod-core.cabal b/yesod-core.cabal index 3c456749..dd1ace89 100644 --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.8.0 +version: 0.8.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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