From 801f6dea3be43113400e41aabb443456fffcd227 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 28 Feb 2013 23:39:40 -0400 Subject: [PATCH 1/2] remove TH --- Yesod/Core.hs | 10 ---- Yesod/Dispatch.hs | 119 +---------------------------------------------- Yesod/Handler.hs | 27 +---------- Yesod/Internal/Cache.hs | 5 -- Yesod/Internal/Core.hs | 119 +++++------------------------------------------ Yesod/Widget.hs | 29 ------------ 6 files changed, 13 insertions(+), 296 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 7268d6c..ce04b7d 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -21,16 +21,6 @@ module Yesod.Core , unauthorizedI -- * Logging , LogLevel (..) - , logDebug - , logInfo - , logWarn - , logError - , logOther - , logDebugS - , logInfoS - , logWarnS - , logErrorS - , logOtherS -- * Sessions , SessionBackend (..) , defaultClientSessionBackend diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 1e19388..dd37475 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -6,20 +6,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Yesod.Dispatch ( -- * Quasi-quoted routing - parseRoutes - , parseRoutesNoCheck - , parseRoutesFile - , parseRoutesFileNoCheck - , mkYesod - , mkYesodSub -- ** More fine-grained - , mkYesodData - , mkYesodSubData - , mkYesodDispatch - , mkYesodSubDispatch - , mkDispatchInstance -- ** Path pieces - , PathPiece (..) + PathPiece (..) , PathMultiPiece (..) , Texts -- * Convert to WAI @@ -52,117 +41,11 @@ import Data.Monoid (mappend) import qualified Data.ByteString as S import qualified Blaze.ByteString.Builder import Network.HTTP.Types (status301) -import Yesod.Routes.TH import Yesod.Content (chooseRep) -import Yesod.Routes.Parse import System.Log.FastLogger (Logger) type Texts = [Text] --- | Generates URL datatype and site function for the given 'Resource's. This --- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. --- Use 'parseRoutes' to create the 'Resource's. -mkYesod :: String -- ^ name of the argument datatype - -> [ResourceTree String] - -> Q [Dec] -mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False - --- | Generates URL datatype and site function for the given 'Resource's. This --- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter. --- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not --- executable by itself, but instead provides functionality to --- be embedded in other sites. -mkYesodSub :: String -- ^ name of the argument datatype - -> Cxt - -> [ResourceTree String] - -> Q [Dec] -mkYesodSub name clazzes = - fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True - where - (name':rest) = words name - --- | Sometimes, you will want to declare your routes in one file and define --- your handlers elsewhere. For example, this is the only way to break up a --- monolithic file into smaller parts. Use this function, paired with --- 'mkYesodDispatch', to do just that. -mkYesodData :: String -> [ResourceTree String] -> Q [Dec] -mkYesodData name res = mkYesodDataGeneral name [] False res - -mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec] -mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res - -mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec] -mkYesodDataGeneral name clazzes isSub res = do - let (name':rest) = words name - (x, _) <- mkYesodGeneral name' rest clazzes isSub res - let rname = mkName $ "resources" ++ name - eres <- lift res - let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String) - , FunD rname [Clause [] (NormalB eres) []] - ] - return $ x ++ y - --- | See 'mkYesodData'. -mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] -mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False - -mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec] -mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True - where (name':rest) = words name - -mkYesodGeneral :: String -- ^ foundation type - -> [String] -- ^ arguments for the type - -> Cxt -- ^ the type constraints - -> Bool -- ^ it this a subsite - -> [ResourceTree String] - -> Q([Dec],[Dec]) -mkYesodGeneral name args clazzes isSub resS = do - subsite <- sub - masterTypeSyns <- if isSub then return [] - else sequence [handler, widget] - renderRouteDec <- mkRenderRouteInstance subsite res - dispatchDec <- mkDispatchInstance context sub master res - return (renderRouteDec ++ masterTypeSyns, dispatchDec) - where sub = foldl appT subCons subArgs - master = if isSub then (varT $ mkName "master") else sub - context = if isSub then cxt $ yesod : map return clazzes - else return [] - yesod = classP ''Yesod [master] - handler = tySynD (mkName "Handler") [] [t| GHandler $master $master |] - widget = tySynD (mkName "Widget") [] [t| GWidget $master $master () |] - res = map (fmap parseType) resS - subCons = conT $ mkName name - subArgs = map (varT. mkName) args - --- | If the generation of @'YesodDispatch'@ instance require finer --- control of the types, contexts etc. using this combinator. You will --- hardly need this generality. However, in certain situations, like --- when writing library/plugin for yesod, this combinator becomes --- handy. -mkDispatchInstance :: CxtQ -- ^ The context - -> TypeQ -- ^ The subsite type - -> TypeQ -- ^ The master site type - -> [ResourceTree a] -- ^ The resource - -> DecsQ -mkDispatchInstance context sub master res = do - logger <- newName "logger" - let loggerE = varE logger - loggerP = VarP logger - yDispatch = conT ''YesodDispatch `appT` sub `appT` master - thisDispatch = do - Clause pat body decs <- mkDispatchClause - [|yesodRunner $loggerE |] - [|yesodDispatch $loggerE |] - [|fmap chooseRep|] - res - return $ FunD 'yesodDispatch - [ Clause (loggerP:pat) - body - decs - ] - in sequence [instanceD context yDispatch [thisDispatch]] - - -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This is the same as 'toWaiAppPlain', except it includes two -- middlewares: GZIP compression and autohead. This is the diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1997bdb..98c915c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -42,7 +42,6 @@ module Yesod.Handler , RedirectUrl (..) , redirect , redirectWith - , redirectToPost -- ** Errors , notFound , badMethod @@ -100,7 +99,6 @@ module Yesod.Handler , getMessageRender -- * Per-request caching , CacheKey - , mkCacheKey , cacheLookup , cacheInsert , cacheDelete @@ -172,7 +170,7 @@ import System.Log.FastLogger import Control.Monad.Logger import qualified Yesod.Internal.Cache as Cache -import Yesod.Internal.Cache (mkCacheKey, CacheKey) +import Yesod.Internal.Cache (CacheKey) import qualified Data.IORef as I import Control.Exception.Lifted (catch) import Control.Monad.Trans.Control @@ -937,29 +935,6 @@ newIdent = do put x { ghsIdent = i' } return $ T.pack $ 'h' : show i' --- | Redirect to a POST resource. --- --- This is not technically a redirect; instead, it returns an HTML page with a --- POST form, and some Javascript to automatically submit the form. This can be --- useful when you need to post a plain link somewhere that needs to cause --- changes on the server. -redirectToPost :: RedirectUrl master url => url -> GHandler sub master a -redirectToPost url = do - urlText <- toTextUrl url - hamletToRepHtml [hamlet| -$newline never -$doctype 5 - - - - Redirecting... - <body onload="document.getElementById('form').submit()"> - <form id="form" method="post" action=#{urlText}> - <noscript> - <p>Javascript has been disabled; please click on the button below to be redirected. - <input type="submit" value="Continue"> -|] >>= sendResponse - -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content diff --git a/Yesod/Internal/Cache.hs b/Yesod/Internal/Cache.hs index 4aec0d2..fdef9d7 100644 --- a/Yesod/Internal/Cache.hs +++ b/Yesod/Internal/Cache.hs @@ -3,7 +3,6 @@ module Yesod.Internal.Cache ( Cache , CacheKey - , mkCacheKey , lookup , insert , delete @@ -24,10 +23,6 @@ newtype Cache = Cache (Map.IntMap Any) newtype CacheKey a = CacheKey Int --- | Generate a new 'CacheKey'. Be sure to give a full type signature. -mkCacheKey :: Q Exp -mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique) - lookup :: CacheKey a -> Cache -> Maybe a lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs index c4a9796..90c05fc 100644 --- a/Yesod/Internal/Core.hs +++ b/Yesod/Internal/Core.hs @@ -44,7 +44,6 @@ module Yesod.Internal.Core import Yesod.Content import Yesod.Handler hiding (lift, getExpires) -import Control.Monad.Logger (logErrorS) import Yesod.Routes.Class import Data.Time (UTCTime, addUTCTime, getCurrentTime) @@ -165,22 +164,7 @@ class RenderRoute a => Yesod a where -- | Applies some form of layout to the contents of a page. defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml - defaultLayout w = do - p <- widgetToPageContent w - mmsg <- getMessage - hamletToRepHtml [hamlet| -$newline never -$doctype 5 - -<html> - <head> - <title>#{pageTitle p} - ^{pageHead p} - <body> - $maybe msg <- mmsg - <p .message>#{msg} - ^{pageBody p} -|] + defaultLayout w = error "defaultLayout not implemented" -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid @@ -521,46 +505,11 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep -defaultErrorHandler NotFound = do - r <- waiRequest - let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r - applyLayout' "Not Found" - [hamlet| -$newline never -<h1>Not Found -<p>#{path'} -|] -defaultErrorHandler (PermissionDenied msg) = - applyLayout' "Permission Denied" - [hamlet| -$newline never -<h1>Permission denied -<p>#{msg} -|] -defaultErrorHandler (InvalidArgs ia) = - applyLayout' "Invalid Arguments" - [hamlet| -$newline never -<h1>Invalid Arguments -<ul> - $forall msg <- ia - <li>#{msg} -|] -defaultErrorHandler (InternalError e) = do - $logErrorS "yesod-core" e - applyLayout' "Internal Server Error" - [hamlet| -$newline never -<h1>Internal Server Error -<pre>#{e} -|] -defaultErrorHandler (BadMethod m) = - applyLayout' "Bad Method" - [hamlet| -$newline never -<h1>Method Not Supported -<p>Method <code>#{S8.unpack m}</code> not supported -|] +defaultErrorHandler NotFound = error "Not Found" +defaultErrorHandler (PermissionDenied msg) = error "Permission Denied" +defaultErrorHandler (InvalidArgs ia) = error "Invalid Arguments" +defaultErrorHandler (InternalError e) = error "Internal Server Error" +defaultErrorHandler (BadMethod m) = error "Bad Method" -- | Return the same URL if the user is authorized to see it. -- @@ -616,45 +565,10 @@ widgetToPageContent w = do -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing -- the asynchronous loader means your page doesn't have to wait for all the js to load let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc - regularScriptLoad = [hamlet| -$newline never -$forall s <- scripts - ^{mkScriptTag s} -$maybe j <- jscript - $maybe s <- jsLoc - <script src="#{s}"> - $nothing - <script>^{jelper j} -|] - - headAll = [hamlet| -$newline never -\^{head'} -$forall s <- stylesheets - ^{mkLinkTag s} -$forall s <- css - $maybe t <- right $ snd s - $maybe media <- fst s - <link rel=stylesheet media=#{media} href=#{t}> - $nothing - <link rel=stylesheet href=#{t}> - $maybe content <- left $ snd s - $maybe media <- fst s - <style media=#{media}>#{content} - $nothing - <style>#{content} -$case jsLoader master - $of BottomOfBody - $of BottomOfHeadAsync asyncJsLoader - ^{asyncJsLoader asyncScripts mcomplete} - $of BottomOfHeadBlocking - ^{regularScriptLoad} -|] - let bodyScript = [hamlet| -$newline never -^{body} -^{regularScriptLoad} -|] + regularScriptLoad = error "TODO" + + headAll = error "TODO" + let bodyScript = error "TODO" return $ PageContent title headAll (case jsLoader master of BottomOfBody -> bodyScript @@ -696,18 +610,7 @@ jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String -- | For use with setting 'jsLoader' to 'BottomOfHeadAsync' loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master)) -loadJsYepnope eyn scripts mcomplete = - [hamlet| -$newline never - $maybe yn <- left eyn - <script src=#{yn}> - $maybe yn <- right eyn - <script src=@{yn}> - $maybe complete <- mcomplete - <script>yepnope({load:#{jsonArray scripts},complete:function(){^{complete}}}); - $nothing - <script>yepnope({load:#{jsonArray scripts}}); -|] +loadJsYepnope eyn scripts mcomplete = error "TODO" asyncHelper :: (url -> [x] -> Text) -> [Script (url)] diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index bd94bd3..bf79150 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -15,8 +15,6 @@ module Yesod.Widget GWidget , PageContent (..) -- * Special Hamlet quasiquoter/TH for Widgets - , whamlet - , whamletFile , ihamletToRepHtml -- * Convert to Widget , ToWidget (..) @@ -54,7 +52,6 @@ module Yesod.Widget , addScriptEither -- * Internal , unGWidget - , whamletFileWithSettings ) where import Data.Monoid @@ -274,32 +271,6 @@ data PageContent url = PageContent , pageBody :: HtmlUrl url } -whamlet :: QuasiQuoter -whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings - -whamletFile :: FilePath -> Q Exp -whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings - -whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp -whamletFileWithSettings = NP.hamletFileWithSettings rules - -rules :: Q NP.HamletRules -rules = do - ah <- [|toWidget|] - let helper qg f = do - x <- newName "urender" - e <- f $ VarE x - let e' = LamE [VarP x] e - g <- qg - bind <- [|(>>=)|] - return $ InfixE (Just g) bind (Just e') - let ur f = do - let env = NP.Env - (Just $ helper [|liftW getUrlRenderParams|]) - (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|]) - f env - return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b - -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. ihamletToRepHtml :: RenderMessage master message => HtmlUrlI18n message (Route master) -- 1.7.10.4