mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
git-annex/standalone/android/haskell-patches/yesod-core-1.1.8_0001-remove-TH.patch
Joey Hess d9459a75b0 expanded some TH
2013-03-01 01:15:53 -04:00

476 lines
16 KiB
Diff
Raw Blame History

From 801f6dea3be43113400e41aabb443456fffcd227 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
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
-
-<html>
- <head>
- <title>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
Reference in a new issue View git blame Copy permalink